diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.res b/analysis/examples/example-project/src/syntax/sample-highlighting.res new file mode 100644 index 000000000..b3fd724d0 --- /dev/null +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.res @@ -0,0 +1,73 @@ +// Bindings +let numberBinding = 123 + +let someFunction = (param: int): int => { + let innerBinding = param + 2 + innerBinding +} + +// Types +type someRecord<'typeParameter> = { + someField: int, + someOtherField: string, + theParam: typeParameter, +} + +type someEnum = + | SomeMember + | AnotherMember + | SomeMemberWithPayload(someRecord) + +type somePolyEnum = [ + | #someMember + | #AnotherMember + | #SomeMemberWithPayload(someRecord) + | #"fourth Member" +] + +// Destructuring +let destructuring = () => { + let someVar = (1, 2, 3) + let (one, two, three) = someVar + let someObj: someRecord = { + someField: 1, + someOtherField: "hello", + theParam: 2, + } + let {someField, someOtherField, theParam} = someObj + + someField +} + +module SomeModule = { + type t = Some | Value | Here +} + +// Strings +let interpolated = `${numberBinding} ${"123"}` + +// JSX +module SomeComponent = { + @react.component + let make = ( + ~someProp: int, + ~otherProp: string, + ~thirdProp: SomeModule.t, + ~fourth: somePolyEnum=#"fourth member", + ) => { + React.null + } + + module Nested = { + @react.component + let make = (~children) => { + <> {children} + } + } +} + +let jsx = +
+ + {React.string("Nested")} +
diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.rs b/analysis/examples/example-project/src/syntax/sample-highlighting.rs new file mode 100644 index 000000000..7131ba600 --- /dev/null +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.rs @@ -0,0 +1,31 @@ +// Bindings +fn some_function(param: usize) -> usize { + let innerBinding = param + 2; + innerBinding +} + +// Types +struct someRecord { + someField: usize, + someOtherField: String, + theParam: typeParameter, +} + +enum someEnum { + SomeMember, + AnotherMember, + SomeMemberWithPayload(someRecord), +} + +// Destructuring +fn destructuring() -> usize { + let someVar = (1, 2, 3); + let (one, two, three) = someVar; + let someObj = someRecord:: { + someField: 1, + someOtherField: String::new("HEllo"), + theParam: 2, + }; + + someObj.someField +} diff --git a/analysis/examples/example-project/src/syntax/sample-highlighting.tsx b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx new file mode 100644 index 000000000..4aa092c8a --- /dev/null +++ b/analysis/examples/example-project/src/syntax/sample-highlighting.tsx @@ -0,0 +1,68 @@ +// Bindings +let numberBinding = 123; + +const SomeComp = { + Nested: () => null, +}; + +let someFunction = (param: number): number => { + let innerBinding = param + 2; + return innerBinding; +}; + +// Types +type someRecord = { + someField: number; + someOtherField: string; + theParam: typeParameter; +}; + +enum someEnum { + SomeMember, + AnotherMember, +} + +// Destructuring +let destructuring = () => { + let someVar = [1, 2, 3]; + let [one, two, three] = someVar; + let someObj: someRecord = { + someField: 1, + someOtherField: "hello", + theParam: 2, + }; + let { someField, someOtherField, theParam } = someObj; + + return someField; +}; + +namespace SomeModule { + export enum t { + Some, + Value, + Here, + } +} + +// Strings +let interpolated = `${numberBinding} ${"123"}`; + +// JSX +interface Props { + someProp: number; + otherProp: string; + thirdProp: SomeModule.t; +} +const SomeComponent = ({ someProp, otherProp, thirdProp }: Props) => { + return null; +}; + +let jsx = ( +
+ +
+); diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml index cc08302ea..cf56d3bbc 100644 --- a/analysis/src/Cli.ml +++ b/analysis/src/Cli.ml @@ -70,6 +70,8 @@ let main () = ~col:(int_of_string col) | _ :: "dump" :: files -> Commands.dump files | [_; "documentSymbol"; path] -> Commands.documentSymbol ~path + | [_; "semanticTokens"; currentFile] -> + SemanticTokens.testCommand ~currentFile | [_; "hover"; path; line; col] -> Commands.hover ~path ~line:(int_of_string line) ~col:(int_of_string col) | [_; "references"; path; line; col] -> @@ -83,6 +85,6 @@ let main () = | _ -> prerr_endline help; exit 1 - ;; + main () diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 74504e8ba..a9945d469 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -314,7 +314,6 @@ let test ~path = print_endline ("Hover " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col); - hover ~path ~line ~col | "ref" -> print_endline @@ -331,7 +330,6 @@ let test ~path = ("Rename " ^ path ^ " " ^ string_of_int line ^ ":" ^ string_of_int col ^ " " ^ newName) in - rename ~path ~line ~col ~newName | "com" -> print_endline @@ -349,6 +347,11 @@ let test ~path = close_out cout; completion ~path ~line ~col ~currentFile; Sys.remove currentFile + | "par" -> + print_endline ("Parse " ^ path); + SemanticTokens.parser ~debug:true + ~emitter:(SemanticTokens.Token.createEmitter ()) + ~path | _ -> ()); print_newline ()) in diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index 91c94511d..a39d74e92 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -1276,10 +1276,8 @@ let rec resolvePath ~env ~path ~package = | Some file -> resolvePath ~env:(QueryEnv.fromFile file) ~path:fullPath ~package)) -let tupleOfLexing {Lexing.pos_lnum; pos_cnum; pos_bol} = - (pos_lnum - 1, pos_cnum - pos_bol) - -let locationIsBefore {Location.loc_start} pos = tupleOfLexing loc_start <= pos +let locationIsBefore {Location.loc_start} pos = + Utils.tupleOfLexing loc_start <= pos let findInScope pos name iter stamps = (* Log.log("Find " ++ name ++ " with " ++ string_of_int(Hashtbl.length(stamps)) ++ " stamps"); *) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml new file mode 100644 index 000000000..a1c049257 --- /dev/null +++ b/analysis/src/SemanticTokens.ml @@ -0,0 +1,381 @@ +module Token = struct + type legend = {tokenTypes : string array; tokenModifiers : string array} + + (* This needs to stay synced with the same legend in `server.ts` *) + (* See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens *) + type tokenType = + | Keyword + | Variable + | Type + | JsxTag + | Namespace + | EnumMember + | Property + + type tokenModifiers = NoModifier + + let tokenTypeToString = function + | Keyword -> "0" + | Variable -> "1" + | Type -> "2" + | JsxTag -> "3" + | Namespace -> "4" + | EnumMember -> "5" + | Property -> "6" + + let tokenTypeDebug = function + | Keyword -> "Keyword" + | Variable -> "Variable" + | Type -> "Type" + | JsxTag -> "JsxTag" + | Namespace -> "Namespace" + | EnumMember -> "EnumMember" + | Property -> "Property" + + let tokenModifiersToString = function NoModifier -> "0" + + type token = int * int * int * tokenType * tokenModifiers + + type emitter = { + mutable tokens : token list; + mutable lastLine : int; + mutable lastChar : int; + } + + let createEmitter () = {tokens = []; lastLine = 0; lastChar = 0} + + let add ~line ~char ~length ~type_ ?(modifiers = NoModifier) e = + e.tokens <- (line, char, length, type_, modifiers) :: e.tokens + + let emitToken buf (line, char, length, type_, modifiers) e = + let deltaLine = line - e.lastLine in + let deltaChar = if deltaLine = 0 then char - e.lastChar else char in + e.lastLine <- line; + e.lastChar <- char; + if Buffer.length buf > 0 then Buffer.add_char buf ','; + Buffer.add_string buf + (string_of_int deltaLine ^ "," ^ string_of_int deltaChar ^ "," + ^ string_of_int length ^ "," ^ tokenTypeToString type_ ^ "," + ^ tokenModifiersToString modifiers) + + let emit e = + let sortedTokens = + e.tokens + |> List.sort (fun (l1, c1, _, _, _) (l2, c2, _, _, _) -> + if l1 = l2 then compare c1 c2 else compare l1 l2) + in + let buf = Buffer.create 1 in + sortedTokens |> List.iter (fun t -> e |> emitToken buf t); + Buffer.contents buf +end + +let locToPositions (loc : Location.t) = + (Utils.tupleOfLexing loc.loc_start, Utils.tupleOfLexing loc.loc_end) + +let posToString (loc, col) = Printf.sprintf "(%d,%d)" loc col + +let locToString (loc : Location.t) = + let posStart, posEnd = locToPositions loc in + Printf.sprintf "%s->%s" (posToString posStart) (posToString posEnd) + +let isLowercaseId id = + let c = id.[0] in + c == '_' || (c >= 'a' && c <= 'z') + +let isUppercaseId id = + let c = id.[0] in + c >= 'A' && c <= 'Z' + +let emitFromPos posStart posEnd ~type_ emitter = + let length = + if fst posStart = fst posEnd then snd posEnd - snd posStart else 0 + in + if length > 0 then + emitter + |> Token.add ~line:(fst posStart) ~char:(snd posStart) ~length ~type_ + +let emitFromLoc ~loc ~type_ emitter = + let posStart, posEnd = locToPositions loc in + emitter |> emitFromPos posStart posEnd ~type_ + +let emitLongident ?(backwards = false) ?(jsx = false) + ?(lowerCaseToken = Token.Variable) ?(upperCaseToken = Token.Namespace) ~pos + ~lid ~debug emitter = + let rec flatten acc lid = + match lid with + | Longident.Lident txt -> txt :: acc + | Ldot (lid, txt) -> + let acc = if jsx && txt = "createElement" then acc else txt :: acc in + flatten acc lid + | _ -> acc + in + let rec loop pos segments = + match segments with + | [id] when isUppercaseId id || isLowercaseId id -> + let type_ = if isUppercaseId id then upperCaseToken else lowerCaseToken in + if debug then + Printf.printf "Lident: %s %s %s\n" id (posToString pos) + (Token.tokenTypeDebug type_); + emitter |> emitFromPos pos (fst pos, snd pos + String.length id) ~type_ + | id :: segments when isUppercaseId id || isLowercaseId id -> + let type_ = if isUppercaseId id then upperCaseToken else lowerCaseToken in + if debug then + Printf.printf "Ldot: %s %s %s\n" id (posToString pos) + (Token.tokenTypeDebug type_); + let length = String.length id in + emitter |> emitFromPos pos (fst pos, snd pos + length) ~type_; + loop (fst pos, snd pos + length + 1) segments + | _ -> () + in + let segments = flatten [] lid in + if backwards then ( + let totalLength = segments |> String.concat "." |> String.length in + if snd pos >= totalLength then + loop (fst pos, snd pos - totalLength) segments) + else loop pos segments + +let emitVariable ~id ~debug ~loc emitter = + if debug then Printf.printf "Variable: %s %s\n" id (locToString loc); + emitter |> emitFromLoc ~loc ~type_:Variable + +let emitJsxOpen ~lid ~debug ~loc emitter = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing loc.Location.loc_start) + ~lid ~jsx:true ~debug + +let emitJsxClose ~lid ~debug ~pos emitter = + emitter |> emitLongident ~backwards:true ~pos ~lid ~jsx:true ~debug + +let emitJsxTag ~debug ~pos emitter = + if debug then Printf.printf "JsxTag >: %s\n" (posToString pos); + emitter |> emitFromPos pos (fst pos, snd pos + 1) ~type_:Token.JsxTag + +let emitType ~id ~debug ~loc emitter = + if debug then Printf.printf "Type: %s %s\n" id (locToString loc); + emitter |> emitFromLoc ~loc ~type_:Token.Type + +let emitRecordLabel ~(label : Longident.t Location.loc) ~debug emitter = + emitter + |> emitLongident ~lowerCaseToken:Token.Property + ~pos:(Utils.tupleOfLexing label.loc.loc_start) + ~lid:label.txt ~debug + +let emitVariant ~(name : Longident.t Location.loc) ~debug emitter = + emitter + |> emitLongident ~upperCaseToken:Token.EnumMember + ~pos:(Utils.tupleOfLexing name.loc.loc_start) + ~lid:name.txt ~debug + +let parser ~debug ~emitter ~path = + let processTypeArg (coreType : Parsetree.core_type) = + if debug then Printf.printf "TypeArg: %s\n" (locToString coreType.ptyp_loc) + in + let typ (mapper : Ast_mapper.mapper) (coreType : Parsetree.core_type) = + match coreType.ptyp_desc with + | Ptyp_constr ({txt; loc}, args) -> + (match txt with + | Lident id -> emitter |> emitType ~id ~debug ~loc + | _ -> ()); + args |> List.iter processTypeArg; + Ast_mapper.default_mapper.typ mapper coreType + | _ -> Ast_mapper.default_mapper.typ mapper coreType + in + let type_declaration (mapper : Ast_mapper.mapper) + (tydecl : Parsetree.type_declaration) = + emitter + |> emitType ~id:tydecl.ptype_name.txt ~debug ~loc:tydecl.ptype_name.loc; + Ast_mapper.default_mapper.type_declaration mapper tydecl + in + let pat (mapper : Ast_mapper.mapper) (p : Parsetree.pattern) = + match p.ppat_desc with + | Ppat_var {txt = id} -> + if isLowercaseId id then + emitter |> emitVariable ~id ~debug ~loc:p.ppat_loc; + Ast_mapper.default_mapper.pat mapper p + | Ppat_record (cases, _) -> + cases + |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug); + Ast_mapper.default_mapper.pat mapper p + | Ppat_construct (name, _) -> + emitter |> emitVariant ~name ~debug; + Ast_mapper.default_mapper.pat mapper p + | _ -> Ast_mapper.default_mapper.pat mapper p + in + let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_ident {txt = lid; loc} -> + emitter + |> emitLongident ~pos:(Utils.tupleOfLexing loc.loc_start) ~lid ~debug; + Ast_mapper.default_mapper.expr mapper e + | Pexp_apply ({pexp_desc = Pexp_ident lident; pexp_loc}, args) + when Res_parsetree_viewer.isJsxExpression e -> + let rec isSelfClosing args = + match args with + | [] -> false + | [ + ( Asttypes.Labelled "children", + { + Parsetree.pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, None); + } ); + _; + ] -> + true + | _ :: rest -> isSelfClosing rest + in + emitter |> emitJsxOpen ~lid:lident.txt ~debug ~loc:pexp_loc; + (if not (isSelfClosing args) then + let lineStart, colStart = Utils.tupleOfLexing pexp_loc.loc_start in + let lineEnd, colEnd = Utils.tupleOfLexing pexp_loc.loc_end in + let length = if lineStart = lineEnd then colEnd - colStart else 0 in + let lineEndWhole, colEndWhole = Utils.tupleOfLexing e.pexp_loc.loc_end in + if length > 0 && colEndWhole > length then ( + emitter + |> emitJsxClose ~debug ~lid:lident.txt + ~pos:(lineEndWhole, colEndWhole - 1); + + let rec emitGreatherthanAfterProps args = + match args with + | (Asttypes.Labelled "children", {Parsetree.pexp_loc = {loc_start}}) + :: _ -> + emitter |> emitJsxTag ~debug ~pos:(Utils.tupleOfLexing loc_start) + | _ :: args -> emitGreatherthanAfterProps args + | [] -> () + in + emitGreatherthanAfterProps args (* <-- *); + emitter (* ... <-- *) + |> emitJsxTag ~debug + ~pos: + (let pos = Utils.tupleOfLexing e.pexp_loc.loc_end in + (fst pos, snd pos - 1)))); + (* only process again arguments, not the jsx label *) + let _ = args |> List.map (fun (_lbl, arg) -> mapper.expr mapper arg) in + e + | Pexp_apply ({pexp_loc}, _) when Res_parsetree_viewer.isBinaryExpression e + -> + if debug then Printf.printf "BinaryExp: %s\n" (locToString pexp_loc); + Ast_mapper.default_mapper.expr mapper e + | Pexp_record (cases, _) -> + cases + |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug); + Ast_mapper.default_mapper.expr mapper e + | Pexp_field (_, label) | Pexp_setfield (_, label, _) -> + emitter |> emitRecordLabel ~label ~debug; + Ast_mapper.default_mapper.expr mapper e + | Pexp_construct (name, _) -> + emitter |> emitVariant ~name ~debug; + Ast_mapper.default_mapper.expr mapper e + | _ -> Ast_mapper.default_mapper.expr mapper e + in + let module_expr (mapper : Ast_mapper.mapper) (me : Parsetree.module_expr) = + match me.pmod_desc with + | Pmod_ident {txt = lid; loc} -> + emitter + |> emitLongident ~pos:(Utils.tupleOfLexing loc.loc_start) ~lid ~debug; + Ast_mapper.default_mapper.module_expr mapper me + | _ -> Ast_mapper.default_mapper.module_expr mapper me + in + let module_binding (mapper : Ast_mapper.mapper) + (mb : Parsetree.module_binding) = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing mb.pmb_name.loc.loc_start) + ~lid:(Longident.Lident mb.pmb_name.txt) ~debug; + Ast_mapper.default_mapper.module_binding mapper mb + in + let module_declaration (mapper : Ast_mapper.mapper) + (md : Parsetree.module_declaration) = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing md.pmd_name.loc.loc_start) + ~lid:(Longident.Lident md.pmd_name.txt) ~debug; + Ast_mapper.default_mapper.module_declaration mapper md + in + let module_type (mapper : Ast_mapper.mapper) (mt : Parsetree.module_type) = + match mt.pmty_desc with + | Pmty_ident {txt = lid; loc} -> + emitter + |> emitLongident ~upperCaseToken:Token.Type + ~pos:(Utils.tupleOfLexing loc.loc_start) + ~lid ~debug; + Ast_mapper.default_mapper.module_type mapper mt + | _ -> Ast_mapper.default_mapper.module_type mapper mt + in + let module_type_declaration (mapper : Ast_mapper.mapper) + (mtd : Parsetree.module_type_declaration) = + emitter + |> emitLongident ~upperCaseToken:Token.Type + ~pos:(Utils.tupleOfLexing mtd.pmtd_name.loc.loc_start) + ~lid:(Longident.Lident mtd.pmtd_name.txt) ~debug; + Ast_mapper.default_mapper.module_type_declaration mapper mtd + in + let open_description (mapper : Ast_mapper.mapper) + (od : Parsetree.open_description) = + emitter + |> emitLongident + ~pos:(Utils.tupleOfLexing od.popen_lid.loc.loc_start) + ~lid:od.popen_lid.txt ~debug; + Ast_mapper.default_mapper.open_description mapper od + in + let label_declaration (mapper : Ast_mapper.mapper) + (ld : Parsetree.label_declaration) = + emitter + |> emitRecordLabel + ~label:{loc = ld.pld_name.loc; txt = Longident.Lident ld.pld_name.txt} + ~debug; + Ast_mapper.default_mapper.label_declaration mapper ld + in + let constructor_declaration (mapper : Ast_mapper.mapper) + (cd : Parsetree.constructor_declaration) = + emitter + |> emitVariant + ~name:{loc = cd.pcd_name.loc; txt = Longident.Lident cd.pcd_name.txt} + ~debug; + Ast_mapper.default_mapper.constructor_declaration mapper cd + in + + let mapper = + { + Ast_mapper.default_mapper with + constructor_declaration; + expr; + label_declaration; + module_declaration; + module_binding; + module_expr; + module_type; + module_type_declaration; + open_description; + pat; + typ; + type_declaration; + } + in + + if Filename.check_suffix path ".res" then ( + let parser = + Res_driver.parsingEngine.parseImplementation ~forPrinter:false + in + let {Res_driver.parsetree = structure; diagnostics} = + parser ~filename:path + in + if debug then + Printf.printf "structure items:%d diagnostics:%d \n" + (List.length structure) (List.length diagnostics); + mapper.structure mapper structure |> ignore) + else + let parser = Res_driver.parsingEngine.parseInterface ~forPrinter:false in + let {Res_driver.parsetree = signature; diagnostics} = + parser ~filename:path + in + if debug then + Printf.printf "signature items:%d diagnostics:%d \n" + (List.length signature) (List.length diagnostics); + mapper.signature mapper signature |> ignore + +let testCommand ~currentFile = + let emitter = Token.createEmitter () in + parser ~emitter ~debug:false ~path:currentFile; + (* emitter |> Token.add ~line:0 ~char:0 ~length:3 ~type_:Token.Keyword; *) + Printf.printf "{\"data\":[%s]}" (Token.emit emitter) diff --git a/analysis/src/vendor/compiler-libs-406/parse.ml b/analysis/src/vendor/compiler-libs-406/parse.ml new file mode 100644 index 000000000..ba89f0e2e --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/parse.ml @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Entry points in the parser *) + +(* Skip tokens to the end of the phrase *) + +let rec skip_phrase lexbuf = + try + match Lexer.token lexbuf with + Parser.SEMISEMI | 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 +;; + +let maybe_skip_phrase lexbuf = + if Parsing.is_current_lookahead Parser.SEMISEMI + || Parsing.is_current_lookahead Parser.EOF + then () + else skip_phrase lexbuf + +let wrap parsing_fun lexbuf = + try + Docstrings.init (); + Lexer.init (); + let ast = parsing_fun Lexer.token lexbuf in + Parsing.clear_parser(); + Docstrings.warn_bad_docstrings (); + ast + 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 + | 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 implementation = wrap Parser.implementation +and interface = wrap Parser.interface +and toplevel_phrase = wrap Parser.toplevel_phrase +and use_file = wrap Parser.use_file +and core_type = wrap Parser.parse_core_type +and expression = wrap Parser.parse_expression +and pattern = wrap Parser.parse_pattern diff --git a/analysis/src/vendor/compiler-libs-406/parse.mli b/analysis/src/vendor/compiler-libs-406/parse.mli new file mode 100644 index 000000000..8e6eb4544 --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/parse.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Entry points in the parser *) + +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 core_type : Lexing.lexbuf -> Parsetree.core_type +val expression : Lexing.lexbuf -> Parsetree.expression +val pattern : Lexing.lexbuf -> Parsetree.pattern diff --git a/analysis/src/vendor/compiler-libs-406/pprintast.ml b/analysis/src/vendor/compiler-libs-406/pprintast.ml new file mode 100644 index 000000000..4956e8dc6 --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/pprintast.ml @@ -0,0 +1,1498 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) + +open Asttypes +open Format +open Location +open Longident +open Parsetree +open Ast_helper + +let prefix_symbols = [ '!'; '?'; '~' ] ;; +let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; + '$'; '%'; '#' ] + +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] + +(* 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 fixity_of_string = function + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | _ -> `Normal + +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal + +let is_infix = function | `Infix _ -> true | _ -> false +let is_mixfix = function `Mixfix _ -> true | _ -> false + +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix + || is_mixfix fix + || List.mem txt.[0] prefix_symbols + +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = + txt.[0]='*' || txt.[String.length txt - 1] = '*' + +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in fprintf ppf format txt + +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" in + fprintf ppf format print_longident longprefix txt + +type space_formatter = (unit, Format.formatter, unit) format + +let override = function + | Override -> "!" + | Fresh -> "" + +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | Invariant -> "" + | Covariant -> "+" + | Contravariant -> "-" + +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `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 "[]";_},_); + pexp_attributes = []} -> + (List.rev acc,true) + | {pexp_desc= + Pexp_construct ({txt=Lident "::";_}, + Some ({pexp_desc= Pexp_tuple([e1;e2]); + pexp_attributes = []})); + pexp_attributes = []} + -> + 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_construct :construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = { + pipe : bool; + semi : bool; + ifthenelse : bool; +} + +let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } +let under_pipe ctxt = { ctxt with pipe=true } +let under_semi ctxt = { ctxt with semi=true } +let under_ifthenelse ctxt = { ctxt with ifthenelse=true } +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) + +let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> + ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> + Format.formatter -> 'a list -> unit + = fun ?sep ?first ?last fu f xs -> + let first = match first with Some x -> x |None -> ("": _ format6) + and last = match last with Some x -> x |None -> ("": _ format6) + and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x::xs -> fu f x; pp f sep; loop f xs; + | _ -> assert false in begin + pp f first; loop f xs; pp f last; + end in + aux f xs + +let option : 'a. ?first:space_formatter -> ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + = fun ?first ?last fu f a -> + let first = match first with Some x -> x | None -> ("": _ format6) + and last = match last with Some x -> x | None -> ("": _ format6) in + match a with + | None -> () + | Some x -> pp f first; fu f x; pp f last + +let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> + bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit + = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> + if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") + else fu f x + +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot(y,s) -> protect_longident f longident y s + | Lapply (y,s) -> + pp f "%a(%a)" longident y longident s + +let longident_loc f x = pp f "%a" longident x.txt + +let constant f = function + | Pconst_char i -> pp f "%C" i + | Pconst_string (i, None) -> pp f "%S" i + | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) + | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> + pp f "%s%c" i m) f (i,m) + +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" +let virtual_flag f = function + | Concrete -> () + | Virtual -> pp f "virtual@;" + +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " + +let constant_string f s = pp f "%S" s +let tyvar f str = pp f "'%s" str +let tyvar_loc f str = pp f "'%s" str.txt +let string_quot f x = pp f "`%s" x + +(* c ['a,'b] *) +let rec class_params_def ctxt f = function + | [] -> () + | l -> + pp f "[%a] " (* space *) + (list (type_param ctxt) ~sep:",") l + +and type_with_label ctxt f (label, c) = + match label with + | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) + | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c + | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c + +and core_type ctxt f x = + if x.ptyp_attributes <> [] then begin + pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} + (attributes ctxt) x.ptyp_attributes + end + else match x.ptyp_desc with + | Ptyp_arrow (l, ct1, ct2) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 + | Ptyp_alias (ct, s) -> + pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s + | Ptyp_poly ([], ct) -> + core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> + pp f "%a" + (fun f l -> match l with + | [] -> () + | _ -> + pp f "%a@;.@;" + (list tyvar_loc ~sep:"@;") l) + l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x + +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else match x.ptyp_desc with + | Ptyp_any -> pp f "_"; + | Ptyp_var s -> tyvar f s; + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> match l with + |[] -> () + |[x]-> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let type_variant_helper f x = + match x with + | Rtag (l, attrs, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" string_quot l.txt + (fun f l -> match l with + |[] -> () + | _ -> pp f "@;of@;%a" + (list (core_type ctxt) ~sep:"&") ctl) ctl + (attributes ctxt) attrs + | Rinherit ct -> core_type ctxt f ct in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match l, closed with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed,low) with + | (Closed,None) -> "" + | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) + | (Open,_) -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") l) l + (fun f low -> match low with + |Some [] |None -> () + |Some xs -> + pp f ">@ %a" + (list string_quot) xs) low + | Ptyp_object (l, o) -> + let core_field_type f = function + | Otag (l, attrs, ct) -> + pp f "@[%s: %a@ %a@ @]" l.txt + (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) + | Oinherit ct -> + pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> + match l with + | [] -> pp f ".." + | _ -> pp f " ;.." + in + pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l + field_var o (* Cf #7200 *) + | Ptyp_class (li, l) -> (*FIXME*) + pp f "@[%a#%a@]" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l + longident_loc li + | Ptyp_package (lid, cstrs) -> + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in + (match cstrs with + |[] -> pp f "@[(module@ %a)@]" longident_loc lid + |_ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x + +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) + | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> + list_of_pattern (p2::acc) p1 + | x -> x::acc + in + if x.ppat_attributes <> [] then begin + pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} + (attributes ctxt) x.ppat_attributes + end + else match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) + | Ppat_or _ -> (* *) + pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) + (list_of_pattern [] x) + | _ -> pattern1 ctxt f x + +and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = + let rec pattern_list_helper f = function + | {ppat_desc = + Ppat_construct + ({ txt = Lident("::") ;_}, + Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); + ppat_attributes = []} + + -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x + | Ppat_construct (({txt;_} as li), po) -> + (* FIXME The third field always false *) + if txt = Lident "::" then + pp f "%a" pattern_list_helper x + else + (match po with + | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x + +and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else match x.ppat_desc with + | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x + | Ppat_any -> pp f "_"; + | Ppat_var ({txt = txt;_}) -> protect_ident f txt + | Ppat_array l -> + pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack (s) -> + pp f "(module@ %s)@ " s.txt + | Ppat_type li -> + pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> + let longident_x_pattern f (li, p) = + match (li,p) with + | ({txt=Lident s;_ }, + {ppat_desc=Ppat_var {txt;_}; + ppat_attributes=[]; _}) + when s = txt -> + pp f "@[<2>%a@]" longident_loc li + | _ -> + pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + in + begin match closed with + | Closed -> + pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> + pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l + end + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant (c) -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l,None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_lazy p -> + pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p + | Ppat_exception p -> + pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false + | _ -> true in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) p + | _ -> paren true (pattern ctxt) f x + +and label_exp ctxt f (l,opt,p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional rest -> + begin match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = rest -> + (match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> + (match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" + rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) + end + | Labelled l -> match p with + | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} + when txt = l -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p + +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else match e.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; + pexp_attributes=[]; _}, args) + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin + let print_indexop a path_prefix assign left right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m in + match assign, rem_args with + | false, [] -> + pp f "@[%a%a%s%a%s@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right; true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" + (simple_expr ctxt) a print_path path_prefix + left (list ~sep:"," print_index) indices right + (simple_expr ctxt) v; true + | _ -> false in + match id, List.map snd args with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; true + | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin + let assign = func = "set" in + let print = print_indexop a None assign in + match path, other_args with + | Lident "Array", i :: rest -> + print ".(" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest + | Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> + print ".{" "}" (simple_expr ctxt) indexes rest + | _ -> false + end + | (Lident s | Ldot(_,s)) , a :: i :: rest + when s.[0] = '.' -> + let n = String.length s in + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let assign = s.[n - 1] = '-' in + let kind = + (* extract the right end bracket *) + if assign then s.[n - 3] else s.[n - 1] in + let left, right = match kind with + | ')' -> '(', ")" + | ']' -> '[', "]" + | '}' -> '{', "}" + | _ -> assert false in + let path_prefix = match id with + | Ldot(m,_) -> Some m + | _ -> None in + let left = String.sub s 0 (1+String.index s left) in + print_indexop a path_prefix assign left right + (expression ctxt) [i] rest + | _ -> false + end + | _ -> false + +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} + (attributes ctxt) x.pexp_attributes + else match x.pexp_desc with + | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun (l, e0, p, e) -> + pp f "@[<2>fun@;%a->@;%a@]" + (label_exp ctxt) (l, e0, p) + (expression ctxt) e + | Pexp_function l -> + pp f "@[function%a@]" (case_list ctxt) l + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + (expression reset_ctxt) e (case_list ctxt) l + + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" + (bindings reset_ctxt) (rf,l) + (expression ctxt) e + | Pexp_apply (e, l) -> + begin if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> + begin match l with + | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) arg1 s + (label_x_expression_param ctxt) arg2 + | _ -> + pp f "@[<2>%a %a@]" + (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | `Prefix s -> + let s = + if List.mem s ["~+";"~-";"~+.";"~-."] && + (match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + |[(_,{pexp_desc=Pexp_constant _})] -> false + | _ -> true) + then String.sub s 1 (String.length s -1) + else s in + begin match l with + | [(Nolabel, x)] -> + pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) l + end + | _ -> + pp f "@[%a@]" begin fun f (e,l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) l + (* reset here only because [function,match,try,sequence] + are lower priority *) + end (e,l) + end + + | Pexp_construct (li, Some eo) + when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) + (match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> + pp f "@[<2>%a@;%a@]" longident_loc li + (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" + (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> match eo with + | Some x -> + pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> + sequence_helper (e1::acc) e2 + | v -> List.rev (v::acc) in + let lst = sequence_helper [] x in + pp f "@[%a@]" + (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_new (li) -> + pp f "@[new@ %a@]" longident_loc li; + | Pexp_setinstvar (s, e) -> + pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e + | Pexp_override l -> (* FIXME *) + let string_x_expression f (s, e) = + pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in + pp f "@[{<%a>}@]" + (list string_x_expression ~sep:";" ) l; + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) cd + (expression ctxt) e + | Pexp_assert e -> + pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_lazy (e) -> + pp f "@[lazy@ %a@]" (simple_expr ctxt) e + (* Pexp_poly: impossible but we should print it anyway, rather than + assert false *) + | Pexp_poly (e, None) -> + pp f "@[!poly!@ %a@]" (simple_expr ctxt) e + | Pexp_poly (e, Some ct) -> + pp f "@[(!poly!@ %a@ : %a)@]" + (simple_expr ctxt) e (core_type ctxt) ct + | Pexp_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (expression ctxt) e + | Pexp_variant (l,Some eo) -> + pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_extension e -> extension ctxt f e + | Pexp_unreachable -> pp f "." + | _ -> expression1 ctxt f x + +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs + | _ -> expression2 ctxt f x +(* used in [Pexp_apply] *) + +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + + | _ -> simple_expr ctxt f x + +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> + (match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" + (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> + longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c; + | Pexp_pack me -> + pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_newtype (lid, e) -> + pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, cto1, ct) -> + pp f "(%a%a :> %a)" (expression ctxt) e + (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) + (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f ( li, e) = + match e with + | {pexp_desc=Pexp_ident {txt;_}; + pexp_attributes=[]; _} when li.txt = txt -> + pp f "@[%a@]" longident_loc li + | _ -> + pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) eo + (list longident_x_expression ~sep:";@;") l + | Pexp_array (l) -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") l + | Pexp_while (e1, e2) -> + let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt:(_,_,_)format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag + df expression e2 expression e3 + | _ -> paren true (expression ctxt) f x + +and attributes ctxt f l = + List.iter (attribute ctxt f) l + +and item_attributes ctxt f l = + List.iter (item_attribute ctxt f) l + +and attribute ctxt f (s, e) = + pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e + +and item_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and floating_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + if x.pval_prim <> [] + then pp f "@ =@ %a" (list constant_string) x.pval_prim + ) x + +and extension ctxt f (s, e) = + pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + +and exception_declaration ctxt f ext = + pp f "@[exception@ %a@]" (extension_constructor ctxt) ext + +and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = + let class_type_field f x = + match x.pctf_desc with + | Pctf_inherit (ct) -> + pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_val (s, mf, vf, ct) -> + pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" + mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_method (s, pf, vf, ct) -> + pp f "@[<2>method %a %a%s :@;%a@]%a" + private_flag pf virtual_flag vf s.txt (core_type ctxt) ct + (item_attributes ctxt) x.pctf_attributes + | Pctf_constraint (ct1, ct2) -> + pp f "@[<2>constraint@ %a@ =@ %a@]%a" + (core_type ctxt) ct1 (core_type ctxt) ct2 + (item_attributes ctxt) x.pctf_attributes + | Pctf_attribute a -> floating_attribute ctxt f a + | Pctf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pctf_attributes + in + pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" + (fun f -> function + {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () + | ct -> pp f " (%a)" (core_type ctxt) ct) ct + (list class_type_field ~sep:"@;") l + +(* call [class_signature] called by [class_signature] *) +and class_type ctxt f x = + match x.pcty_desc with + | Pcty_signature cs -> + class_signature ctxt f cs; + attributes ctxt f x.pcty_attributes + | Pcty_constr (li, l) -> + pp f "%a%a%a" + (fun f l -> match l with + | [] -> () + | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l + longident_loc li + (attributes ctxt) x.pcty_attributes + | Pcty_arrow (l, co, cl) -> + pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) + (type_with_label ctxt) (l,co) + (class_type ctxt) cl + | Pcty_extension e -> + extension ctxt f e; + attributes ctxt f x.pcty_attributes + | Pcty_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (class_type ctxt) e + +(* [class type a = object end] *) +and class_type_declaration_list ctxt f l = + let class_type_declaration kwd f x = + let { pci_params=ls; pci_name={ txt; _ }; _ } = x in + pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in + match l with + | [] -> () + | [x] -> class_type_declaration "class type" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_type_declaration "class type") x + (list ~sep:"@," (class_type_declaration "and")) xs + +and class_field ctxt f x = + match x.pcf_desc with + | Pcf_inherit () -> () + | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> + pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) + mutable_flag mf s.txt + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_virtual ct) -> + pp f "@[<2>method virtual %a %s :@;%a@]%a" + private_flag pf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_val (s, mf, Cfk_virtual ct) -> + pp f "@[<2>val virtual %a%s :@ %a@]%a" + mutable_flag mf s.txt + (core_type ctxt) ct + (item_attributes ctxt) x.pcf_attributes + | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> + let bind e = + binding ctxt f + {pvb_pat= + {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; + pvb_expr=e; + pvb_attributes=[]; + pvb_loc=Location.none; + } + in + pp f "@[<2>method%s %a%a@]%a" + (override ovf) + private_flag pf + (fun f -> function + | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> + pp f "%s :@;%a=@;%a" + s.txt (core_type ctxt) ct (expression ctxt) e + | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> + bind e + | _ -> bind e) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_constraint (ct1, ct2) -> + pp f "@[<2>constraint %a =@;%a@]%a" + (core_type ctxt) ct1 + (core_type ctxt) ct2 + (item_attributes ctxt) x.pcf_attributes + | Pcf_initializer (e) -> + pp f "@[<2>initializer@ %a@]%a" + (expression ctxt) e + (item_attributes ctxt) x.pcf_attributes + | Pcf_attribute a -> floating_attribute ctxt f a + | Pcf_extension e -> + item_extension ctxt f e; + item_attributes ctxt f x.pcf_attributes + +and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = + pp f "@[@[object%a@;%a@]@;end@]" + (fun f p -> match p.ppat_desc with + | Ppat_any -> () + | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p + | _ -> pp f " (%a)" (pattern ctxt) p) p + (list (class_field ctxt)) l + +and class_expr ctxt f x = + if x.pcl_attributes <> [] then begin + pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} + (attributes ctxt) x.pcl_attributes + end else + match x.pcl_desc with + | Pcl_structure (cs) -> class_structure ctxt f cs + | Pcl_fun (l, eo, p, e) -> + pp f "fun@ %a@ ->@ %a" + (label_exp ctxt) (l,eo,p) + (class_expr ctxt) e + | Pcl_let (rf, l, ce) -> + pp f "%a@ in@ %a" + (bindings ctxt) (rf,l) + (class_expr ctxt) ce + | Pcl_apply (ce, l) -> + pp f "((%a)@ %a)" (* Cf: #7200 *) + (class_expr ctxt) ce + (list (label_x_expression_param ctxt)) l + | Pcl_constr (li, l) -> + pp f "%a%a" + (fun f l-> if l <>[] then + pp f "[%a]@ " + (list (core_type ctxt) ~sep:",") l) l + longident_loc li + | Pcl_constraint (ce, ct) -> + pp f "(%a@ :@ %a)" + (class_expr ctxt) ce + (class_type ctxt) ct + | Pcl_extension e -> extension ctxt f e + | Pcl_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (class_expr ctxt) e + +and module_type ctxt f x = + if x.pmty_attributes <> [] then begin + pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} + (attributes ctxt) x.pmty_attributes + end else + match x.pmty_desc with + | Pmty_ident li -> + pp f "%a" longident_loc li; + | Pmty_alias li -> + pp f "(module %a)" longident_loc li; + | Pmty_signature (s) -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) s (* FIXME wrong indentation*) + | Pmty_functor (_, None, mt2) -> + pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (s, Some mt1, mt2) -> + if s.txt = "_" then + pp f "@[%a@ ->@ %a@]" + (module_type ctxt) mt1 (module_type ctxt) mt2 + else + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt + (module_type ctxt) mt1 (module_type ctxt) mt2 + | Pmty_with (mt, l) -> + let with_constraint f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 in + (match l with + | [] -> pp f "@[%a@]" (module_type ctxt) mt + | _ -> pp f "@[(%a@ with@ %a)@]" + (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e + +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> + type_def_list ctxt f (rf, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> + type_extension ctxt f te + | Psig_exception ed -> + exception_declaration ctxt f ed + | Psig_class l -> + let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = + pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd + virtual_flag x.pci_virt + (class_params_def ctxt) ls txt + (class_type ctxt) x.pci_expr + (item_attributes ctxt) x.pci_attributes + in begin + match l with + | [] -> () + | [x] -> class_description "class" f x + | x :: xs -> + pp f "@[%a@,%a@]" + (class_description "class") x + (list ~sep:"@," (class_description "and")) xs + end + | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; + pmty_attributes=[]; _};_} as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt + longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" + pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" + (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Psig_class_type (l) -> class_type_declaration_list ctxt f l + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first=true) l = + match l with + | [] -> () ; + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type + (item_attributes ctxt) pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} + (attributes ctxt) x.pmod_attributes + else match x.pmod_desc with + | Pmod_structure (s) -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") s; + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" + (module_expr ctxt) me + (module_type ctxt) mt + | Pmod_ident (li) -> + pp f "%a" longident_loc li; + | Pmod_functor (_, None, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (s, Some mt, me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" + s.txt (module_type ctxt) mt (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_unpack e -> + pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e + +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> pp f ":"; core_type ctxt f x + | PSig x -> pp f ":"; signature ctxt f x + | PPat (x, None) -> pp f "?"; pattern ctxt f x + | PPat (x, Some e) -> + pp f "?"; pattern ctxt f x; + pp f " when "; expression ctxt f e + +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else match x.pexp_desc with + | Pexp_fun (label, eo, p, e) -> + if label=Nolabel then + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e + else + pp f "%a@ %a" + (label_exp ctxt) (label,eo,p) pp_print_pexp_function e + | Pexp_newtype (str,e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in + let is_desugared_gadt p e = + let gadt_pattern = + match p with + | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, + {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); + ppat_attributes=[]}-> + Some (pat, args_tyvars, rt) + | _ -> None in + let rec gadt_exp tyvars e = + match e with + | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> + gadt_exp (tyvar :: tyvars) e + | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> + Some (List.rev tyvars, e, ct) + | _ -> None in + let gadt_exp = gadt_exp [] e in + match gadt_pattern, gadt_exp with + | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = Typ.varify_constructors e_tyvars e_ct in + if ety = pt_ct then + Some (p, pt_tyvars, e_ct, e) else None + | _ -> None in + if x.pexp_attributes <> [] + then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" + (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e + | Some (p, tyvars, ct, e) -> begin + pp f "%a@;: type@;%a.@;%a@;=@;%a" + (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + end + | None -> begin + match p with + | {ppat_desc=Ppat_constraint(p ,ty); + ppat_attributes=[]} -> (* special case for the first*) + begin match ty with + | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p + (core_type ctxt) ty (expression ctxt) x + end + | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + end + +(* [in] is not printed *) +and bindings ctxt f (rf,l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf + (binding ctxt) x (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x::xs -> + pp f "@[%a@,%a@]" + (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) xs + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" + (expression ctxt) e + (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf,l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" + x.pmb_name.txt + (fun f me -> + let me = module_helper me in + match me with + | {pmod_desc= + Pmod_constraint + (me', + ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_));_} as mt)); + pmod_attributes = []} -> + pp f " :@;%a@;=@;%a@;" + (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me + ) x.pmb_expr + (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + longident_loc od.popen_lid + (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + pp f "@[module@ type@ %s%a@]%a" + s.txt + (fun f md -> match md with + | None -> () + | Some mt -> + pp_print_space f () ; + pp f "@ =@ %a" (module_type ctxt) mt + ) md + (item_attributes ctxt) attrs + | Pstr_class () -> () + | Pstr_class_type l -> class_type_declaration_list ctxt f l + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" + protect_ident vd.pval_name.txt + (value_description ctxt) vd + (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" + (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> (* 3.07 *) + let aux f = function + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + | _ -> assert false + in + begin match decls with + | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" + pmb.pmb_name.txt + (module_type ctxt) typ + (module_expr ctxt) expr + (item_attributes ctxt) pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) l2 + | _ -> assert false + end + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension(e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, a) = + pp f "%s%a" (type_variance a) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, l) = + let type_decl kwd rf f x = + let eq = + if (x.ptype_kind = Ptype_abstract) + && (x.ptype_manifest = None) then "" + else " =" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd + nonrec_flag rf + (type_params ctxt) x.ptype_params + x.ptype_name.txt eq + (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> pp f "@[%a@,%a@]" + (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s:@;%a@;%a@]" + mutable_flag pld.pld_mutable + pld.pld_name.txt + (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" + (list type_record_field ~sep:";@\n" ) lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else + pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = + if x.ptype_manifest = None then () + else pp f "@;=" + in + match x.ptype_kind with + | Ptype_variant xs -> + pp f "%t%t@\n%a" intro priv + (list ~sep:"@\n" constructor_declaration) xs + | Ptype_abstract -> () + | Ptype_record l -> + pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1,ct2,_) -> + pp f "@[@ constraint@ %a@ =@ %a@]" + (core_type ctxt) ct1 (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params + longident_loc x.ptyext_path + private_flag x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors + (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l + ) args + (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") l + (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r + ) + args + (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl(l, r) -> + constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s%a@;=@;%a" x.pext_name.txt + (attributes ctxt) x.pext_attributes + longident_loc li + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" + (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") + pc_guard (expression (under_pipe ctxt)) pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l,e) = + let simple_name = match e with + | {pexp_desc=Pexp_ident {txt=Lident l;_}; + pexp_attributes=[]} -> Some l + | _ -> None + in match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional str -> + if Some str = simple_name then + pp f "?%s" str + else + pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled lbl -> + if Some lbl = simple_name then + pp f "~%s" lbl + else + pp f "~%s:%a" lbl (simple_expr ctxt) e + +and directive_argument f x = + match x with + | Pdir_none -> () + | Pdir_string (s) -> pp f "@ %S" s + | Pdir_int (n, None) -> pp f "@ %s" n + | Pdir_int (n, Some m) -> pp f "@ %s%c" n m + | Pdir_ident (li) -> pp f "@ %a" longident li + | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) + +let toplevel_phrase f x = + match x with + | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s + (* pp_open_hvbox f 0; *) + (* pp_print_list structure_item f s ; *) + (* pp_close_box f (); *) + | Ptop_dir (s, da) -> + pp f "@[#%s@ %a@]" s directive_argument da + (* pp f "@[#%s@ %a@]" s directive_argument da *) + +let expression f x = + pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()) ; + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + +let top_phrase f x = + pp_print_newline f (); + toplevel_phrase f x; + pp f ";;"; + pp_print_newline f () + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt diff --git a/analysis/src/vendor/compiler-libs-406/printast.ml b/analysis/src/vendor/compiler-libs-406/printast.ml new file mode 100644 index 000000000..7e8e7bad4 --- /dev/null +++ b/analysis/src/vendor/compiler-libs-406/printast.ml @@ -0,0 +1,918 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes;; +open Format;; +open Lexing;; +open Location;; +open Parsetree;; + +let fmt_position with_name f l = + let fname = if with_name then l.pos_fname else "" in + if l.pos_lnum = -1 + then fprintf f "%s[%d]" fname l.pos_cnum + else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) +;; + +let fmt_location f loc = + let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in + fprintf f "(%a..%a)" (fmt_position true) loc.loc_start + (fmt_position p_2nd_name) loc.loc_end; + if loc.loc_ghost then fprintf f " ghost"; +;; + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident (s) -> fprintf f "%s" s; + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; +;; + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x;; + +let fmt_longident_loc f (x : Longident.t loc) = + fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc; +;; + +let fmt_string_loc f (x : string loc) = + fprintf f "\"%s\" %a" x.txt fmt_location x.loc; +;; + +let fmt_char_option f = function + | None -> fprintf f "None" + | Some c -> fprintf f "Some %c" c + +let fmt_constant f x = + match x with + | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; + | Pconst_char (c) -> fprintf f "PConst_char %02x" (Char.code c); + | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; + | Pconst_string (s, Some delim) -> + fprintf f "PConst_string (%S,Some %S)" s delim; + | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m; +;; + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable"; + | Mutable -> fprintf f "Mutable"; +;; + +let fmt_virtual_flag f x = + match x with + | Virtual -> fprintf f "Virtual"; + | Concrete -> fprintf f "Concrete"; +;; + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override"; + | Fresh -> fprintf f "Fresh"; +;; + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec"; + | Recursive -> fprintf f "Rec"; +;; + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up"; + | Downto -> fprintf f "Down"; +;; + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public"; + | Private -> fprintf f "Private"; +;; + +let line i f s (*...*) = + fprintf f "%s" (String.make ((2*i) mod 72) ' '); + fprintf f s (*...*) +;; + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n"; + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i+1) ppf) l; + line i ppf "]\n"; +;; + +let option i f ppf x = + match x with + | None -> line i ppf "None\n"; + | Some x -> + line i ppf "Some\n"; + f (i+1) ppf x; +;; + +let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;; +let string i ppf s = line i ppf "\"%s\"\n" s;; +let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;; +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional s -> line i ppf "Optional \"%s\"\n" s + | Labelled s -> line i ppf "Labelled \"%s\"\n" s +;; + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ptyp_loc; + attributes i ppf x.ptyp_attributes; + let i = i+1 in + match x.ptyp_desc with + | Ptyp_any -> line i ppf "Ptyp_any\n"; + | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; + | Ptyp_arrow (l, ct1, ct2) -> + line i ppf "Ptyp_arrow\n"; + arg_label i ppf l; + core_type i ppf ct1; + core_type i ppf ct2; + | Ptyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l; + | Ptyp_constr (li, l) -> + line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Ptyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ptyp_object (l, c) -> + line i ppf "Ptyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter ( + function + | Otag (l, attrs, t) -> + line i ppf "method %s\n" l.txt; + attributes i ppf attrs; + core_type (i + 1) ppf t + | Oinherit ct -> + line i ppf "Oinherit\n"; + core_type (i + 1) ppf ct + ) l + | Ptyp_class (li, l) -> + line i ppf "Ptyp_class %a\n" fmt_longident_loc li; + list i core_type ppf l + | Ptyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct; + | Ptyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) sl; + core_type i ppf ct; + | Ptyp_package (s, l) -> + line i ppf "Ptyp_package %a\n" fmt_longident_loc s; + list i package_with ppf l; + | Ptyp_extension (s, arg) -> + line i ppf "Ptyp_extension \"%s\"\n" s.txt; + payload i ppf arg + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident_loc s; + core_type i ppf t + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.ppat_loc; + attributes i ppf x.ppat_attributes; + let i = i+1 in + match x.ppat_desc with + | Ppat_any -> line i ppf "Ppat_any\n"; + | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; + | Ppat_alias (p, s) -> + line i ppf "Ppat_alias %a\n" fmt_string_loc s; + pattern i ppf p; + | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; + | Ppat_interval (c1, c2) -> + line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; + | Ppat_tuple (l) -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l; + | Ppat_construct (li, po) -> + line i ppf "Ppat_construct %a\n" fmt_longident_loc li; + option i pattern ppf po; + | Ppat_variant (l, po) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po; + | Ppat_record (l, c) -> + line i ppf "Ppat_record %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l; + | Ppat_array (l) -> + line i ppf "Ppat_array\n"; + list i pattern ppf l; + | Ppat_or (p1, p2) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2; + | Ppat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; + | Ppat_constraint (p, ct) -> + line i ppf "Ppat_constraint\n"; + pattern i ppf p; + core_type i ppf ct; + | Ppat_type (li) -> + line i ppf "Ppat_type\n"; + longident_loc i ppf li + | Ppat_unpack s -> + line i ppf "Ppat_unpack %a\n" fmt_string_loc s; + | Ppat_exception p -> + line i ppf "Ppat_exception\n"; + pattern i ppf p + | Ppat_open (m,p) -> + line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; + pattern i ppf p + | Ppat_extension (s, arg) -> + line i ppf "Ppat_extension \"%s\"\n" s.txt; + payload i ppf arg + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.pexp_loc; + attributes i ppf x.pexp_attributes; + let i = i+1 in + match x.pexp_desc with + | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; + | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; + | Pexp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e; + | Pexp_function l -> + line i ppf "Pexp_function\n"; + list i case ppf l; + | Pexp_fun (l, eo, p, e) -> + line i ppf "Pexp_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + expression i ppf e; + | Pexp_apply (e, l) -> + line i ppf "Pexp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l; + | Pexp_match (e, l) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i case ppf l; + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i case ppf l; + | Pexp_tuple (l) -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l; + | Pexp_construct (li, eo) -> + line i ppf "Pexp_construct %a\n" fmt_longident_loc li; + option i expression ppf eo; + | Pexp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo; + | Pexp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo; + | Pexp_field (e, li) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + longident_loc i ppf li; + | Pexp_setfield (e1, li, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + longident_loc i ppf li; + expression i ppf e2; + | Pexp_array (l) -> + line i ppf "Pexp_array\n"; + list i expression ppf l; + | Pexp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo; + | Pexp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2; + | Pexp_for (p, e1, e2, df, e3) -> + line i ppf "Pexp_for %a\n" fmt_direction_flag df; + pattern i ppf p; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3; + | Pexp_constraint (e, ct) -> + line i ppf "Pexp_constraint\n"; + expression i ppf e; + core_type i ppf ct; + | Pexp_coerce (e, cto1, cto2) -> + line i ppf "Pexp_coerce\n"; + expression i ppf e; + option i core_type ppf cto1; + core_type i ppf cto2; + | Pexp_send (e, s) -> + line i ppf "Pexp_send \"%s\"\n" s.txt; + expression i ppf e; + | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; + | Pexp_setinstvar (s, e) -> + line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; + expression i ppf e; + | Pexp_override (l) -> + line i ppf "Pexp_override\n"; + list i string_x_expression ppf l; + | Pexp_letmodule (s, me, e) -> + line i ppf "Pexp_letmodule %a\n" fmt_string_loc s; + module_expr i ppf me; + expression i ppf e; + | Pexp_letexception (cd, e) -> + line i ppf "Pexp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e; + | Pexp_assert (e) -> + line i ppf "Pexp_assert\n"; + expression i ppf e; + | Pexp_lazy (e) -> + line i ppf "Pexp_lazy\n"; + expression i ppf e; + | Pexp_poly (e, cto) -> + line i ppf "Pexp_poly\n"; + expression i ppf e; + option i core_type ppf cto; + | Pexp_object s -> + line i ppf "Pexp_object\n"; + class_structure i ppf s + | Pexp_newtype (s, e) -> + line i ppf "Pexp_newtype \"%s\"\n" s.txt; + expression i ppf e + | Pexp_pack me -> + line i ppf "Pexp_pack\n"; + module_expr i ppf me + | Pexp_open (ovf, m, e) -> + line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident_loc m; + expression i ppf e + | Pexp_extension (s, arg) -> + line i ppf "Pexp_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pexp_unreachable -> + line i ppf "Pexp_unreachable" + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_string_loc + x.pval_name fmt_location x.pval_loc; + attributes i ppf x.pval_attributes; + core_type (i+1) ppf x.pval_type; + list (i+1) string ppf x.pval_prim + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name + fmt_location x.ptype_loc; + attributes i ppf x.ptype_attributes; + let i = i+1 in + line i ppf "ptype_params =\n"; + list (i+1) type_parameter ppf x.ptype_params; + line i ppf "ptype_cstrs =\n"; + list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; + line i ppf "ptype_manifest =\n"; + option (i+1) core_type ppf x.ptype_manifest + +and attributes i ppf l = + let i = i + 1 in + List.iter + (fun (s, arg) -> + line i ppf "attribute \"%s\"\n" s.txt; + payload (i + 1) ppf arg; + ) + l + +and payload i ppf = function + | PStr x -> structure i ppf x + | PSig x -> signature i ppf x + | PTyp x -> core_type i ppf x + | PPat (x, None) -> pattern i ppf x + | PPat (x, Some g) -> + pattern i ppf x; + line i ppf "\n"; + expression (i + 1) ppf g + + +and type_kind i ppf x = + match x with + | Ptype_abstract -> + line i ppf "Ptype_abstract\n" + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; + list (i+1) constructor_decl ppf l; + | Ptype_record l -> + line i ppf "Ptype_record\n"; + list (i+1) label_decl ppf l; + | Ptype_open -> + line i ppf "Ptype_open\n"; + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.ptyext_attributes; + let i = i+1 in + line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; + line i ppf "ptyext_params =\n"; + list (i+1) type_parameter ppf x.ptyext_params; + line i ppf "ptyext_constructors =\n"; + list (i+1) extension_constructor ppf x.ptyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; + attributes i ppf x.pext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.pext_kind; + +and extension_constructor_kind i ppf x = + match x with + Pext_decl(a, r) -> + line i ppf "Pext_decl\n"; + constructor_arguments (i+1) ppf a; + option (i+1) core_type ppf r; + | Pext_rebind li -> + line i ppf "Pext_rebind\n"; + line (i+1) ppf "%a\n" fmt_longident_loc li; + +and class_type i ppf x = + line i ppf "class_type %a\n" fmt_location x.pcty_loc; + attributes i ppf x.pcty_attributes; + let i = i+1 in + match x.pcty_desc with + | Pcty_constr (li, l) -> + line i ppf "Pcty_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcty_signature (cs) -> + line i ppf "Pcty_signature\n"; + class_signature i ppf cs; + | Pcty_arrow (l, co, cl) -> + line i ppf "Pcty_arrow\n"; + arg_label i ppf l; + core_type i ppf co; + class_type i ppf cl; + | Pcty_extension (s, arg) -> + line i ppf "Pcty_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcty_open (ovf, m, e) -> + line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident_loc m; + class_type i ppf e + +and class_signature i ppf cs = + line i ppf "class_signature\n"; + core_type (i+1) ppf cs.pcsig_self; + list (i+1) class_type_field ppf cs.pcsig_fields; + +and class_type_field i ppf x = + line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; + let i = i+1 in + attributes i ppf x.pctf_attributes; + match x.pctf_desc with + | Pctf_inherit (ct) -> + line i ppf "Pctf_inherit\n"; + class_type i ppf ct; + | Pctf_val (s, mf, vf, ct) -> + line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_method (s, pf, vf, ct) -> + line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf + fmt_virtual_flag vf; + core_type (i+1) ppf ct; + | Pctf_constraint (ct1, ct2) -> + line i ppf "Pctf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pctf_attribute (s, arg) -> + line i ppf "Pctf_attribute \"%s\"\n" s.txt; + payload i ppf arg + | Pctf_extension (s, arg) -> + line i ppf "Pctf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_description i ppf x = + line i ppf "class_description %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_type_declaration i ppf x = + line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_type (i+1) ppf x.pci_expr; + +and class_expr i ppf x = + line i ppf "class_expr %a\n" fmt_location x.pcl_loc; + attributes i ppf x.pcl_attributes; + let i = i+1 in + match x.pcl_desc with + | Pcl_constr (li, l) -> + line i ppf "Pcl_constr %a\n" fmt_longident_loc li; + list i core_type ppf l; + | Pcl_structure (cs) -> + line i ppf "Pcl_structure\n"; + class_structure i ppf cs; + | Pcl_fun (l, eo, p, e) -> + line i ppf "Pcl_fun\n"; + arg_label i ppf l; + option i expression ppf eo; + pattern i ppf p; + class_expr i ppf e; + | Pcl_apply (ce, l) -> + line i ppf "Pcl_apply\n"; + class_expr i ppf ce; + list i label_x_expression ppf l; + | Pcl_let (rf, l, ce) -> + line i ppf "Pcl_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + class_expr i ppf ce; + | Pcl_constraint (ce, ct) -> + line i ppf "Pcl_constraint\n"; + class_expr i ppf ce; + class_type i ppf ct; + | Pcl_extension (s, arg) -> + line i ppf "Pcl_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pcl_open (ovf, m, e) -> + line i ppf "Pcl_open %a \"%a\"\n" fmt_override_flag ovf + fmt_longident_loc m; + class_expr i ppf e + +and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = + line i ppf "class_structure\n"; + pattern (i+1) ppf p; + list (i+1) class_field ppf l; + +and class_field i ppf x = + line i ppf "class_field %a\n" fmt_location x.pcf_loc; + let i = i + 1 in + attributes i ppf x.pcf_attributes; + match x.pcf_desc with + | Pcf_inherit () -> () + | Pcf_val (s, mf, k) -> + line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_method (s, pf, k) -> + line i ppf "Pcf_method %a\n" fmt_private_flag pf; + line (i+1) ppf "%a\n" fmt_string_loc s; + class_field_kind (i+1) ppf k + | Pcf_constraint (ct1, ct2) -> + line i ppf "Pcf_constraint\n"; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + | Pcf_initializer (e) -> + line i ppf "Pcf_initializer\n"; + expression (i+1) ppf e; + | Pcf_attribute (s, arg) -> + line i ppf "Pcf_attribute \"%s\"\n" s.txt; + payload i ppf arg + | Pcf_extension (s, arg) -> + line i ppf "Pcf_extension \"%s\"\n" s.txt; + payload i ppf arg + +and class_field_kind i ppf = function + | Cfk_concrete (o, e) -> + line i ppf "Concrete %a\n" fmt_override_flag o; + expression i ppf e + | Cfk_virtual t -> + line i ppf "Virtual\n"; + core_type i ppf t + +and class_declaration i ppf x = + line i ppf "class_declaration %a\n" fmt_location x.pci_loc; + attributes i ppf x.pci_attributes; + let i = i+1 in + line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; + line i ppf "pci_params =\n"; + list (i+1) type_parameter ppf x.pci_params; + line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; + line i ppf "pci_expr =\n"; + class_expr (i+1) ppf x.pci_expr; + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.pmty_loc; + attributes i ppf x.pmty_attributes; + let i = i+1 in + match x.pmty_desc with + | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; + | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; + | Pmty_signature (s) -> + line i ppf "Pmty_signature\n"; + signature i ppf s; + | Pmty_functor (s, mt1, mt2) -> + line i ppf "Pmty_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt1; + module_type i ppf mt2; + | Pmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i with_constraint ppf l; + | Pmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m; + | Pmty_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and signature i ppf x = list i signature_item ppf x + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.psig_loc; + let i = i+1 in + match x.psig_desc with + | Psig_value vd -> + line i ppf "Psig_value\n"; + value_description i ppf vd; + | Psig_type (rf, l) -> + line i ppf "Psig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Psig_typext te -> + line i ppf "Psig_typext\n"; + type_extension i ppf te + | Psig_exception ext -> + line i ppf "Psig_exception\n"; + extension_constructor i ppf ext; + | Psig_module pmd -> + line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type i ppf pmd.pmd_type + | Psig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i module_declaration ppf decls; + | Psig_modtype x -> + line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Psig_open od -> + line i ppf "Psig_open %a %a\n" + fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes + | Psig_include incl -> + line i ppf "Psig_include\n"; + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes + | Psig_class (l) -> + line i ppf "Psig_class\n"; + list i class_description ppf l; + | Psig_class_type (l) -> + line i ppf "Psig_class_type\n"; + list i class_type_declaration ppf l; + | Psig_extension ((s, arg), attrs) -> + line i ppf "Psig_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Psig_attribute (s, arg) -> + line i ppf "Psig_attribute \"%s\"\n" s.txt; + payload i ppf arg + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i+1) ppf mt + +and with_constraint i ppf x = + match x with + | Pwith_type (lid, td) -> + line i ppf "Pwith_type %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_typesubst (lid, td) -> + line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; + type_declaration (i+1) ppf td; + | Pwith_module (lid1, lid2) -> + line i ppf "Pwith_module %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + | Pwith_modsubst (lid1, lid2) -> + line i ppf "Pwith_modsubst %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2; + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.pmod_loc; + attributes i ppf x.pmod_attributes; + let i = i+1 in + match x.pmod_desc with + | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; + | Pmod_structure (s) -> + line i ppf "Pmod_structure\n"; + structure i ppf s; + | Pmod_functor (s, mt, me) -> + line i ppf "Pmod_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt; + module_expr i ppf me; + | Pmod_apply (me1, me2) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2; + | Pmod_constraint (me, mt) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt; + | Pmod_unpack (e) -> + line i ppf "Pmod_unpack\n"; + expression i ppf e; + | Pmod_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and structure i ppf x = list i structure_item ppf x + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.pstr_loc; + let i = i+1 in + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + line i ppf "Pstr_eval\n"; + attributes i ppf attrs; + expression i ppf e; + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + | Pstr_primitive vd -> + line i ppf "Pstr_primitive\n"; + value_description i ppf vd; + | Pstr_type (rf, l) -> + line i ppf "Pstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l; + | Pstr_typext te -> + line i ppf "Pstr_typext\n"; + type_extension i ppf te + | Pstr_exception ext -> + line i ppf "Pstr_exception\n"; + extension_constructor i ppf ext; + | Pstr_module x -> + line i ppf "Pstr_module\n"; + module_binding i ppf x + | Pstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i module_binding ppf bindings; + | Pstr_modtype x -> + line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Pstr_open od -> + line i ppf "Pstr_open %a %a\n" + fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes + | Pstr_class () -> () + | Pstr_class_type (l) -> + line i ppf "Pstr_class_type\n"; + list i class_type_declaration ppf l; + | Pstr_include incl -> + line i ppf "Pstr_include"; + attributes i ppf incl.pincl_attributes; + module_expr i ppf incl.pincl_mod + | Pstr_extension ((s, arg), attrs) -> + line i ppf "Pstr_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Pstr_attribute (s, arg) -> + line i ppf "Pstr_attribute \"%s\"\n" s.txt; + payload i ppf arg + +and module_declaration i ppf pmd = + string_loc i ppf pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type (i+1) ppf pmd.pmd_type; + +and module_binding i ppf x = + string_loc i ppf x.pmb_name; + attributes i ppf x.pmb_attributes; + module_expr (i+1) ppf x.pmb_expr + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i+1) ppf ct1; + core_type (i+1) ppf ct2; + +and constructor_decl i ppf + {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = + line i ppf "%a\n" fmt_location pcd_loc; + line (i+1) ppf "%a\n" fmt_string_loc pcd_name; + attributes i ppf pcd_attributes; + constructor_arguments (i+1) ppf pcd_args; + option (i+1) core_type ppf pcd_res + +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= + line i ppf "%a\n" fmt_location pld_loc; + attributes i ppf pld_attributes; + line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; + line (i+1) ppf "%a" fmt_string_loc pld_name; + core_type (i+1) ppf pld_type + +and longident_x_pattern i ppf (li, p) = + line i ppf "%a\n" fmt_longident_loc li; + pattern (i+1) ppf p; + +and case i ppf {pc_lhs; pc_guard; pc_rhs} = + line i ppf "\n"; + pattern (i+1) ppf pc_lhs; + begin match pc_guard with + | None -> () + | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g + end; + expression (i+1) ppf pc_rhs; + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i+1) ppf x.pvb_attributes; + pattern (i+1) ppf x.pvb_pat; + expression (i+1) ppf x.pvb_expr + +and string_x_expression i ppf (s, e) = + line i ppf " %a\n" fmt_string_loc s; + expression (i+1) ppf e; + +and longident_x_expression i ppf (li, e) = + line i ppf "%a\n" fmt_longident_loc li; + expression (i+1) ppf e; + +and label_x_expression i ppf (l,e) = + line i ppf "\n"; + arg_label i ppf l; + expression (i+1) ppf e; + +and label_x_bool_x_core_type_list i ppf x = + match x with + Rtag (l, attrs, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i+1) ppf attrs; + list (i+1) core_type ppf ctl + | Rinherit (ct) -> + line i ppf "Rinherit\n"; + core_type (i+1) ppf ct +;; + +let rec toplevel_phrase i ppf x = + match x with + | Ptop_def (s) -> + line i ppf "Ptop_def\n"; + structure (i+1) ppf s; + | Ptop_dir (s, da) -> + line i ppf "Ptop_dir \"%s\"\n" s; + directive_argument i ppf da; + +and directive_argument i ppf x = + match x with + | Pdir_none -> line i ppf "Pdir_none\n" + | Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s; + | Pdir_int (n, None) -> line i ppf "Pdir_int %s\n" n; + | Pdir_int (n, Some m) -> line i ppf "Pdir_int %s%c\n" n m; + | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li; + | Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b); +;; + +let interface ppf x = list 0 signature_item ppf x;; + +let implementation ppf x = list 0 structure_item ppf x;; + +let top_phrase ppf x = toplevel_phrase 0 ppf x;; diff --git a/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml new file mode 100644 index 000000000..87a08ed59 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.ml @@ -0,0 +1,871 @@ +open Ast_helper +open Ast_mapper +open Asttypes +open Parsetree +open Longident + +let rec find_opt p = function [] -> None | x :: l -> if p x then Some x else find_opt p l + +let nolabel = Nolabel + +let labelled str = Labelled str + +let optional str = Optional str + +let isOptional str = match str with Optional _ -> true | _ -> false + +let isLabelled str = match str with Labelled _ -> true | _ -> false + +let getLabel str = match str with Optional str | Labelled str -> str | Nolabel -> "" + +let optionIdent = Lident "option" + +let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) + +let safeTypeFromValue valueStr = + let valueStr = getLabel valueStr in + match String.sub valueStr 0 1 with "_" -> "T" ^ valueStr | _ -> valueStr + [@@raises Invalid_argument] + +let keyType loc = Typ.constr ~loc { loc; txt = optionIdent } [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] + +type 'a children = ListLiteral of 'a | Exact of 'a + +type componentConfig = { propsName : string } + +(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) +let transformChildrenIfListUpper ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( + match accum with + | [ singleElement ] -> Exact singleElement + | accum -> ListLiteral (Exp.array ~loc (List.rev accum)) ) + | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> + transformChildren_ acc (mapper.expr mapper v :: accum) + | notAList -> Exact (mapper.expr mapper notAList) + in + transformChildren_ theList [] + +let transformChildrenIfList ~loc ~mapper theList = + let rec transformChildren_ theList accum = + (* not in the sense of converting a list to an array; convert the AST + reprensentation of a list to the AST reprensentation of an array *) + match theList with + | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> Exp.array ~loc (List.rev accum) + | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> + transformChildren_ acc (mapper.expr mapper v :: accum) + | notAList -> mapper.expr mapper notAList + in + transformChildren_ theList [] + +let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = + let rec allButLast_ lst acc = + match lst with + | [] -> [] + | [ (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }) ] -> acc + | (Nolabel, _) :: _rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") + | arg :: rest -> allButLast_ rest (arg :: acc) + [@@raises Invalid_argument] + in + let allButLast lst = allButLast_ lst [] |> List.rev [@@raises Invalid_argument] in + match List.partition (fun (label, _) -> label = labelled "children") propsAndChildren with + | [], props -> + (* no children provided? Place a placeholder list *) + (Exp.construct ~loc { loc; txt = Lident "[]" } None, if removeLastPositionUnit then allButLast props else props) + | [ (_, childrenExpr) ], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) + | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label") + [@@raises Invalid_argument] + +let unerasableIgnore loc = ({ loc; txt = "warning" }, PStr [ Str.eval (Exp.constant (Pconst_string ("-16", None))) ]) + +let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) + +(* Helper method to look up the [@react.component] attribute *) +let hasAttr (loc, _) = loc.txt = "react.component" + +(* Helper method to filter out any attribute that isn't [@react.component] *) +let otherAttrsPure (loc, _) = loc.txt <> "react.component" + +(* Iterate over the attributes and try to find the [@react.component] attribute *) +let hasAttrOnBinding { pvb_attributes } = find_opt hasAttr pvb_attributes <> None + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let getFnName binding = + match binding with + | { pvb_pat = { ppat_desc = Ppat_var { txt } } } -> txt + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + [@@raises Invalid_argument] + +let makeNewBinding binding expression newName = + match binding with + | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> + { + binding with + pvb_pat = { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; + pvb_expr = expression; + pvb_attributes = [ merlinFocus ]; + } + | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") + [@@raises Invalid_argument] + +(* Lookup the value of `props` otherwise raise Invalid_argument error *) +let getPropsNameValue _acc (loc, exp) = + match (loc, exp) with + | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> { propsName = str } + | { txt }, _ -> + raise (Invalid_argument ("react.component only accepts props as an option, given: " ^ Longident.last txt)) + [@@raises Invalid_argument] + +(* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) +let getPropsAttr payload = + let defaultProps = { propsName = "Props" } in + match payload with + | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _) } :: _rest)) -> + List.fold_left getPropsNameValue defaultProps recordFields + | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _) } :: _rest)) -> + { propsName = "props" } + | Some (PStr ({ pstr_desc = Pstr_eval (_, _) } :: _rest)) -> + raise (Invalid_argument "react.component accepts a record config with props as an options.") + | _ -> defaultProps + [@@raises Invalid_argument] + +(* Plucks the label, loc, and type_ from an AST node *) +let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = (label, default, loc, type_) + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filenameFromLoc (pstr_loc : Location.t) = + let fileName = match pstr_loc.loc_start.pos_fname with "" -> !Location.input_name | fileName -> fileName in + let fileName = try Filename.chop_extension (Filename.basename fileName) with Invalid_argument _ -> fileName in + let fileName = String.capitalize_ascii fileName in + fileName + +(* Build a string representation of a module name with segments separated by $ *) +let makeModuleName fileName nestedModules fnName = + let fullModuleName = + match (fileName, nestedModules, fnName) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | "", nestedModules, "make" -> nestedModules + | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) + | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules + | fileName, nestedModules, fnName -> fileName :: List.rev (fnName :: nestedModules) + in + let fullModuleName = String.concat "$" fullModuleName in + fullModuleName + +(* + AST node builders + These functions help us build AST nodes that are needed when transforming a [@react.component] into a + constructor and a props external +*) + +(* Build an AST node representing all named args for the `external` definition for a component's props *) +let rec recursivelyMakeNamedArgsForExternal list args = + match list with + | (label, default, loc, interiorType) :: tl -> + recursivelyMakeNamedArgsForExternal tl + (Typ.arrow ~loc label + ( match (label, interiorType, default) with + (* ~foo=1 *) + | label, None, Some _ -> + { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } + (* ~foo: int=1 *) + | _label, Some type_, Some _ -> type_ + (* ~foo: option(int)=? *) + | label, Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, _ + | label, Some { ptyp_desc = Ptyp_constr ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]) }, _ + (* ~foo: int=? - note this isnt valid. but we want to get a type error *) + | label, Some type_, _ + when isOptional label -> + type_ + (* ~foo=? *) + | label, None, _ when isOptional label -> + { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } + (* ~foo *) + | label, None, _ -> { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } + | _label, Some type_, _ -> type_ ) + args) + | [] -> args + [@@raises Invalid_argument] + +(* Build an AST node for the [@bs.obj] representing props for a component *) +let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = + let propsName = fnName ^ "Props" in + { + pval_name = { txt = propsName; loc }; + pval_type = + recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef + (Typ.arrow nolabel + { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = [] } + propsType); + pval_prim = [ "" ]; + pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; + pval_loc = loc; + } + [@@raises Invalid_argument] + +(* Build an AST node representing an `external` with the definition of the [@bs.obj] *) +let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType = + { pstr_loc = loc; pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + [@@raises Invalid_argument] + +(* Build an AST node for the signature of the `external` definition *) +let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = + { psig_loc = loc; psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } + [@@raises Invalid_argument] + +(* Build an AST node for the props name when converted to an object inside the function signature *) +let makePropsName ~loc name = { ppat_desc = Ppat_var { txt = name; loc }; ppat_loc = loc; ppat_attributes = [] } + +let makeObjectField loc (str, attrs, type_) = Otag ({ loc; txt = str }, attrs, type_) + +(* Build an AST node representing a "closed" object representing a component's props *) +let makePropsType ~loc namedTypeList = + Typ.mk ~loc (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed)) + +(* Builds an AST node for the entire `external` definition of props *) +let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = + makePropsExternal fnName loc + (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef) + (makePropsType ~loc namedTypeList) + [@@raises Invalid_argument] + +(* TODO: some line number might still be wrong *) +let jsxMapper () = + let jsxVersion = ref None in + + let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = + let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in + let argsForMake = argsWithLabels in + let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in + let recursivelyTransformedArgsForMake = + argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) + in + let childrenArg = ref None in + let args = + recursivelyTransformedArgsForMake + @ ( match childrenExpr with + | Exact children -> [ (labelled "children", children) ] + | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] + | ListLiteral expression -> + (* this is a hack to support react components that introspect into their children *) + childrenArg := Some expression; + [ (labelled "children", Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") }) ] ) + @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] + in + let isCap str = + let first = String.sub str 0 1 [@@raises Invalid_argument] in + let capped = String.uppercase_ascii first in + first = capped + [@@raises Invalid_argument] + in + let ident = + match modulePath with + | Lident _ -> Ldot (modulePath, "make") + | Ldot (_modulePath, value) as fullPath when isCap value -> Ldot (fullPath, "make") + | modulePath -> modulePath + in + let propsIdent = + match ident with + | Lident path -> Lident (path ^ "Props") + | Ldot (ident, path) -> Ldot (ident, path ^ "Props") + | _ -> raise (Invalid_argument "JSX name can't be the result of function applications") + in + let props = Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in + (* handle key, ref, children *) + (* React.createElement(Component.make, props, ...children) *) + match !childrenArg with + | None -> + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] + | Some children -> + Exp.apply ~loc ~attrs + (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElementVariadic") }) + [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props); (nolabel, children) ] + [@@raises Invalid_argument] + in + + let transformLowercaseCall3 mapper loc attrs callArguments id = + let children, nonChildrenProps = extractChildren ~loc callArguments in + let componentNameExpr = constantString ~loc id in + let childrenExpr = transformChildrenIfList ~loc ~mapper children in + let createElementCall = + match children with + (* [@JSX] div(~children=[a]), coming from
a
*) + | { + pexp_desc = + ( Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]" }, None) ); + } -> + "createDOMElementVariadic" + (* [@JSX] div(~children= value), coming from
...(value)
*) + | _ -> + raise + (Invalid_argument + "A spread as a DOM element's children don't make sense written together. You can simply remove the \ + spread.") + in + let args = + match nonChildrenProps with + | [ _justTheUnitArgumentAtEnd ] -> + [ (* "div" *) (nolabel, componentNameExpr); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] + | nonEmptyProps -> + let propsCall = + Exp.apply ~loc + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) + (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) + in + [ + (* "div" *) + (nolabel, componentNameExpr); + (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) + (labelled "props", propsCall); + (* [|moreCreateElementCallsHere|] *) + (nolabel, childrenExpr); + ] + in + Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs + (* ReactDOMRe.createElement *) + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) + args + [@@raises Invalid_argument] + in + + let rec recursivelyTransformNamedArgsForMake mapper expr list = + let expr = mapper.expr mapper expr in + match expr.pexp_desc with + (* TODO: make this show up with a loc. *) + | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> + raise + (Invalid_argument + "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its \ + parent!") + | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> + raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.") + | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> + let () = + match (isOptional arg, pattern, default) with + | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( + match ptyp_desc with + | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () + | _ -> + let currentType = + match ptyp_desc with + | Ptyp_constr ({ txt }, []) -> String.concat "." (Longident.flatten txt) + | Ptyp_constr ({ txt }, _innerTypeArgs) -> String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "ReasonReact: optional argument annotations must have explicit `option`. Did you mean \ + `option(%s)=?`?" + currentType)) ) + | _ -> () + in + let alias = + match pattern with + | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt + | { ppat_desc = Ppat_any } -> "_" + | _ -> getLabel arg + in + let type_ = match pattern with { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ | _ -> None in + + recursivelyTransformNamedArgsForMake mapper expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list) + | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression) -> + (list, None) + | Pexp_fun + ( Nolabel, + _, + { ppat_desc = Ppat_var { txt } | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) }, + _expression ) -> + (list, Some txt) + | Pexp_fun (Nolabel, _, pattern, _expression) -> + Location.raise_errorf ~loc:pattern.ppat_loc + "ReasonReact: react.component refs only support plain arguments and type annotations." + | _ -> (list, None) + [@@raises Invalid_argument] + in + + let argToType types (name, default, _noLabelName, _alias, loc, type_) = + match (type_, name, default) with + | Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, name, _ when isOptional name -> + ( getLabel name, + [], + { type_ with ptyp_desc = Ptyp_constr ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]) } ) + :: types + | Some type_, name, Some _default -> + ( getLabel name, + [], + { ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); ptyp_loc = loc; ptyp_attributes = [] } ) + :: types + | Some type_, name, _ -> (getLabel name, [], type_) :: types + | None, name, _ when isOptional name -> + ( getLabel name, + [], + { + ptyp_desc = + Ptyp_constr + ( { loc; txt = optionIdent }, + [ { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] } ] ); + ptyp_loc = loc; + ptyp_attributes = []; + } ) + :: types + | None, name, _ when isLabelled name -> + (getLabel name, [], { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] }) + :: types + | _ -> types + [@@raises Invalid_argument] + in + + let argToConcreteType types (name, loc, type_) = + match name with + | name when isLabelled name -> (getLabel name, [], type_) :: types + | name when isOptional name -> (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) :: types + | _ -> types + in + + let nestedModules = ref [] in + let transformComponentDefinition mapper structure returnStructures = + match structure with + (* external *) + | { + pstr_loc; + pstr_desc = Pstr_primitive ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); + } as pstr -> ( + match List.filter hasAttr pval_attributes with + | [] -> structure :: returnStructures + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isLabelled name || isOptional name + -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isLabelled name || isOptional name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in + let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in + let externalPropsDecl = + makePropsExternal fnName pstr_loc + ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr ({ loc = pstr_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + in + let newStructure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnStructures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) + (* let component = ... *) + | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> + let fileName = filenameFromLoc pstr_loc in + let emptyLoc = Location.in_file fileName in + let mapBinding binding = + if hasAttrOnBinding binding then + let bindingLoc = binding.pvb_loc in + let bindingPatLoc = binding.pvb_pat.ppat_loc in + let binding = { binding with pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; pvb_loc = emptyLoc } in + let fnName = getFnName binding in + let internalFnName = fnName ^ "$Internal" in + let fullModuleName = makeModuleName fileName !nestedModules fnName in + let modifiedBindingOld binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun _ } -> expression + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } -> + (* here's where we spelunk! *) + spelunkForFunExpression returnExpression + (* let make = React.forwardRef((~prop) => ...) *) + | { pexp_desc = Pexp_apply (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]) } -> + spelunkForFunExpression innerFunctionExpression + | { pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression) } -> + spelunkForFunExpression innerFunctionExpression + | _ -> + raise + (Invalid_argument + "react.component calls can only be on function definitions or component wrappers (forwardRef, \ + memo).") + [@@raises Invalid_argument] + in + spelunkForFunExpression expression + in + let modifiedBinding binding = + let hasApplication = ref false in + let wrapExpressionWithBinding expressionFn expression = + Vb.mk ~loc:bindingLoc + ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) + (Pat.var ~loc:bindingPatLoc { loc = bindingPatLoc; txt = fnName }) + (expressionFn expression) + in + let expression = binding.pvb_expr in + let unerasableIgnoreExp exp = + { exp with pexp_attributes = unerasableIgnore emptyLoc :: exp.pexp_attributes } + in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunkForFunExpression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ( ((Labelled _ | Optional _) as label), + default, + pattern, + ({ pexp_desc = Pexp_fun _ } as internalExpression) ); + } -> + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + ( wrap, + hasUnit, + unerasableIgnoreExp { expression with pexp_desc = Pexp_fun (label, default, pattern, exp) } ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + ( Nolabel, + _default, + { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, + _internalExpression ); + } -> + ((fun a -> a), true, expression) + (* let make = (~prop) => ... *) + | { pexp_desc = Pexp_fun ((Labelled _ | Optional _), _default, _pattern, _internalExpression) } -> + ((fun a -> a), false, unerasableIgnoreExp expression) + (* let make = (prop) => ... *) + | { pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression) } -> + if hasApplication.contents then ((fun a -> a), false, unerasableIgnoreExp expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "ReasonReact: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with React.forwardRef.\n\ + \ If your component doesn't have any props use () or _ instead of a name." + (* let make = {let foo = bar in (~prop) => ...} *) + | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } -> + (* here's where we spelunk! *) + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + (wrap, hasUnit, { expression with pexp_desc = Pexp_let (recursive, vbs, exp) }) + (* let make = React.forwardRef((~prop) => ...) *) + | { pexp_desc = Pexp_apply (wrapperExpression, [ (Nolabel, internalExpression) ]) } -> + let () = hasApplication := true in + let _, hasUnit, exp = spelunkForFunExpression internalExpression in + ((fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), hasUnit, exp) + | { pexp_desc = Pexp_sequence (wrapperExpression, internalExpression) } -> + let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in + (wrap, hasUnit, { expression with pexp_desc = Pexp_sequence (wrapperExpression, exp) }) + | e -> ((fun a -> a), false, e) + in + let wrapExpression, hasUnit, expression = spelunkForFunExpression expression in + (wrapExpressionWithBinding wrapExpression, hasUnit, expression) + in + let bindingWrapper, hasUnit, expression = modifiedBinding binding in + let reactComponentAttribute = + try Some (List.find hasAttr binding.pvb_attributes) with Not_found -> None + in + let _attr_loc, payload = + match reactComponentAttribute with + | Some (loc, payload) -> (loc.loc, Some payload) + | None -> (emptyLoc, None) + in + let props = getPropsAttr payload in + (* do stuff here! *) + let namedArgList, forwardRef = + recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] + in + let namedArgListWithKeyAndRef = + (optional "key", None, Pat.var { txt = "key"; loc = emptyLoc }, "key", emptyLoc, Some (keyType emptyLoc)) + :: namedArgList + in + let namedArgListWithKeyAndRef = + match forwardRef with + | Some _ -> + (optional "ref", None, Pat.var { txt = "key"; loc = emptyLoc }, "ref", emptyLoc, None) + :: namedArgListWithKeyAndRef + | None -> namedArgListWithKeyAndRef + in + let namedArgListWithKeyAndRefForNew = + match forwardRef with + | Some txt -> namedArgList @ [ (nolabel, None, Pat.var { txt; loc = emptyLoc }, txt, emptyLoc, None) ] + | None -> namedArgList + in + let pluckArg (label, _, _, alias, loc, _) = + let labelString = + match label with label when isOptional label || isLabelled label -> getLabel label | _ -> "" + in + ( label, + match labelString with + | "" -> Exp.ident ~loc { txt = Lident alias; loc } + | labelString -> + Exp.apply ~loc + (Exp.ident ~loc { txt = Lident "##"; loc }) + [ + (nolabel, Exp.ident ~loc { txt = Lident props.propsName; loc }); + (nolabel, Exp.ident ~loc { txt = Lident labelString; loc }); + ] ) + in + let namedTypeList = List.fold_left argToType [] namedArgList in + let loc = emptyLoc in + let externalDecl = makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList in + let innerExpressionArgs = + List.map pluckArg namedArgListWithKeyAndRefForNew + @ if hasUnit then [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] else [] + in + let innerExpression = + Exp.apply + (Exp.ident + { loc; txt = Lident (match recFlag with Recursive -> internalFnName | Nonrecursive -> fnName) }) + innerExpressionArgs + in + let innerExpressionWithRef = + match forwardRef with + | Some txt -> + { + innerExpression with + pexp_desc = + Pexp_fun + ( nolabel, + None, + { ppat_desc = Ppat_var { txt; loc = emptyLoc }; ppat_loc = emptyLoc; ppat_attributes = [] }, + innerExpression ); + } + | None -> innerExpression + in + let fullExpression = + Exp.fun_ nolabel None + { + ppat_desc = + Ppat_constraint + (makePropsName ~loc:emptyLoc props.propsName, makePropsType ~loc:emptyLoc namedTypeList); + ppat_loc = emptyLoc; + ppat_attributes = []; + } + innerExpressionWithRef + in + let fullExpression = + match fullModuleName with + | "" -> fullExpression + | txt -> + Exp.let_ Nonrecursive + [ Vb.mk ~loc:emptyLoc (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) fullExpression ] + (Exp.ident ~loc:emptyLoc { loc = emptyLoc; txt = Lident txt }) + in + let bindings, newBinding = + match recFlag with + | Recursive -> + ( [ + bindingWrapper + (Exp.let_ ~loc:emptyLoc Recursive + [ + makeNewBinding binding expression internalFnName; + Vb.mk (Pat.var { loc = emptyLoc; txt = fnName }) fullExpression; + ] + (Exp.ident { loc = emptyLoc; txt = Lident fnName })); + ], + None ) + | Nonrecursive -> + ([ { binding with pvb_expr = expression; pvb_attributes = [] } ], Some (bindingWrapper fullExpression)) + in + (Some externalDecl, bindings, newBinding) + else (None, [ binding ], None) + [@@raises Invalid_argument] + in + let structuresAndBinding = List.map mapBinding valueBindings in + let otherStructures (extern, binding, newBinding) (externs, bindings, newBindings) = + let externs = match extern with Some extern -> extern :: externs | None -> externs in + let newBindings = + match newBinding with Some newBinding -> newBinding :: newBindings | None -> newBindings + in + (externs, binding @ bindings, newBindings) + in + let externs, bindings, newBindings = List.fold_right otherStructures structuresAndBinding ([], [], []) in + externs + @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] + @ ( match newBindings with + | [] -> [] + | newBindings -> [ { pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings) } ] ) + @ returnStructures + | structure -> structure :: returnStructures + [@@raises Invalid_argument] + in + + let reactComponentTransform mapper structures = + List.fold_right (transformComponentDefinition mapper) structures [] + [@@raises Invalid_argument] + in + + let transformComponentSignature _mapper signature returnSignatures = + match signature with + | { psig_loc; psig_desc = Psig_value ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc) } + as psig -> ( + match List.filter hasAttr pval_attributes with + | [] -> signature :: returnSignatures + | [ _ ] -> + let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = + match ptyp_desc with + | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isOptional name || isLabelled name + -> + getPropTypes ((name, ptyp_loc, type_) :: types) rest + | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest + | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> + (returnValue, (name, returnValue.ptyp_loc, type_) :: types) + | _ -> (fullType, types) + in + let innerType, propTypes = getPropTypes [] pval_type in + let namedTypeList = List.fold_left argToConcreteType [] propTypes in + let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in + let retPropsType = makePropsType ~loc:psig_loc namedTypeList in + let externalPropsDecl = + makePropsExternalSig fnName psig_loc + ((optional "key", None, psig_loc, Some (keyType psig_loc)) :: List.map pluckLabelAndLoc propTypes) + retPropsType + in + (* can't be an arrow because it will defensively uncurry *) + let newExternalType = + Ptyp_constr ({ loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) + in + let newStructure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = { pval_type with ptyp_desc = newExternalType }; + pval_attributes = List.filter otherAttrsPure pval_attributes; + }; + } + in + externalPropsDecl :: newStructure :: returnSignatures + | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) + | signature -> signature :: returnSignatures + [@@raises Invalid_argument] + in + + let reactComponentSignatureTransform mapper signatures = + List.fold_right (transformComponentSignature mapper) signatures [] + [@@raises Invalid_argument] + in + + let transformJsxCall mapper callExpression callArguments attrs = + match callExpression.pexp_desc with + | Pexp_ident caller -> ( + match caller with + | { txt = Lident "createElement" } -> + raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") + (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) + | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( + match !jsxVersion with + | None | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) + (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) + (* turn that into + ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) + | { loc; txt = Lident id } -> ( + match !jsxVersion with + | None | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id + | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) + | { txt = Ldot (_, anythingNotCreateElementOrMake) } -> + raise + (Invalid_argument + ( "JSX: the JSX attribute should be attached to a `YourModuleName.createElement` or \ + `YourModuleName.make` call. We saw `" ^ anythingNotCreateElementOrMake ^ "` instead" )) + | { txt = Lapply _ } -> + (* don't think there's ever a case where this is reached *) + raise (Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!") ) + | _ -> raise (Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name.") + [@@raises Invalid_argument] + in + + let signature mapper signature = + default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature + [@@raises Invalid_argument] + in + + let structure mapper structure = + match structure with structures -> default_mapper.structure mapper @@ reactComponentTransform mapper structures + [@@raises Invalid_argument] + in + + let expr mapper expression = + match expression with + (* Does the function application have the @JSX attribute? *) + | { pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes } -> ( + let jsxAttribute, nonJSXAttributes = + List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> transformJsxCall mapper callExpression callArguments nonJSXAttributes ) + (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) + | { + pexp_desc = + ( Pexp_construct ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) + | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); + pexp_attributes; + } as listItems -> ( + let jsxAttribute, nonJSXAttributes = + List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes + in + match (jsxAttribute, nonJSXAttributes) with + (* no JSX attribute *) + | [], _ -> default_mapper.expr mapper expression + | _, nonJSXAttributes -> + let fragment = Exp.ident ~loc { loc; txt = Ldot (Lident "ReasonReact", "fragment") } in + let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in + let args = + [ (* "div" *) (nolabel, fragment); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] + in + Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs:nonJSXAttributes + (* ReactDOMRe.createElement *) + (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "createElement") }) + args ) + (* Delegate to the default mapper, a deep identity traversal *) + | e -> default_mapper.expr mapper e + [@@raises Invalid_argument] + in + + let module_binding mapper module_binding = + let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in + let mapped = default_mapper.module_binding mapper module_binding in + let _ = nestedModules := List.tl !nestedModules in + mapped + [@@raises Failure] + in + { default_mapper with structure; expr; signature; module_binding } + [@@raises Invalid_argument, Failure] + +let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure = + let mapper = jsxMapper () in + mapper.structure mapper code + [@@raises Invalid_argument, Failure] + +let rewrite_signature (code : Parsetree.signature) : Parsetree.signature = + let mapper = jsxMapper () in + mapper.signature mapper code + [@@raises Invalid_argument, Failure] diff --git a/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli new file mode 100644 index 000000000..da60a051c --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/reactjs_jsx_ppx_v3.mli @@ -0,0 +1,39 @@ +(* + This is the module that handles turning Reason JSX' agnostic function call into + a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx + facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension- + points-in-ocaml/ + You wouldn't use this file directly; it's used by ReScript's + bsconfig.json. Specifically, there's a field called `react-jsx` inside the + field `reason`, which enables this ppx through some internal call in bsb +*) + +(* + There are two different transforms that can be selected in this file (v2 and v3): + v2: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createElement("div", ~props={"props1": 1, "props2": b}, [|foo, + bar|])`. + transform `[@JSX] div(~props1=a, ~props2=b, ~children=foo, ())` into + `ReactDOMRe.createElementVariadic("div", ~props={"props1": 1, "props2": b}, foo)`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `ReasonReact.element(~key=a, ~ref=b, Foo.make(~foo=bar, [||]))` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` + v3: + transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into + `ReactDOMRe.createDOMElementVariadic("div", ReactDOMRe.domProps(~props1=1, ~props2=b), [|foo, bar|])`. + transform the upper-cased case + `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into + `React.createElement(Foo.make, Foo.makeProps(~key=a, ~ref=b, ~foo=bar, ()))` + transform the upper-cased case + `[@JSX] Foo.createElement(~foo=bar, ~children=[foo, bar], ())` into + `React.createElementVariadic(Foo.make, Foo.makeProps(~foo=bar, ~children=React.null, ()), [|foo, bar|])` + transform `[@JSX] [foo]` into + `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` +*) + +val rewrite_implementation : Parsetree.structure -> Parsetree.structure + +val rewrite_signature : Parsetree.signature -> Parsetree.signature diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_conversion.ml b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.ml new file mode 100644 index 000000000..20eba5ff5 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.ml @@ -0,0 +1,583 @@ + +let concatLongidents l1 l2 = + let parts1 = Longident.flatten l1 in + let parts2 = Longident.flatten l2 in + match List.concat [parts1; parts2] |> Longident.unflatten with + | Some longident -> longident + | None -> l2 + +(* TODO: support nested open's ? *) +let rec rewritePpatOpen longidentOpen pat = + match pat.Parsetree.ppat_desc with + | Ppat_array (first::rest) -> + (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) + {pat with ppat_desc = Ppat_array ((rewritePpatOpen longidentOpen first)::rest)} + | Ppat_tuple (first::rest) -> + (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) + {pat with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen first)::rest)} + | Ppat_construct( + {txt = Longident.Lident "::"} as listConstructor, + Some ({ppat_desc=Ppat_tuple (pat::rest)} as element) + ) -> + (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) + {pat with ppat_desc = + Ppat_construct ( + listConstructor, + Some {element with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen pat)::rest)} + ) + } + | Ppat_construct ({txt = constructor} as longidentLoc, optPattern) -> + (* Foo.(Bar(a)) -> Foo.Bar(a) *) + {pat with ppat_desc = + Ppat_construct ( + {longidentLoc with txt = concatLongidents longidentOpen constructor}, + optPattern + ) + } + | Ppat_record (({txt = lbl} as longidentLoc, firstPat)::rest, flag) -> + (* Foo.{x} -> {Foo.x: x} *) + let firstRow = ( + {longidentLoc with txt = concatLongidents longidentOpen lbl}, + firstPat + ) in + {pat with ppat_desc = Ppat_record (firstRow::rest, flag)} + | Ppat_or (pat1, pat2) -> + {pat with ppat_desc = Ppat_or ( + rewritePpatOpen longidentOpen pat1, + rewritePpatOpen longidentOpen pat2 + )} + | Ppat_constraint (pattern, typ) -> + {pat with ppat_desc = Ppat_constraint ( + rewritePpatOpen longidentOpen pattern, + typ + )} + | Ppat_type ({txt = constructor} as longidentLoc) -> + {pat with ppat_desc = Ppat_type ( + {longidentLoc with txt = concatLongidents longidentOpen constructor} + )} + | Ppat_lazy p -> + {pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p)} + | Ppat_exception p -> + {pat with ppat_desc = Ppat_exception (rewritePpatOpen longidentOpen p)} + | _ -> pat + +let rec rewriteReasonFastPipe expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "|."}} as op, + [Asttypes.Nolabel, lhs; Nolabel, rhs] + ); pexp_attributes = subAttrs}, + args + ) -> + let rhsLoc = {rhs.pexp_loc with loc_end = expr.pexp_loc.loc_end} in + let newLhs = + let expr = rewriteReasonFastPipe lhs in + {expr with pexp_attributes = List.concat [lhs.pexp_attributes; subAttrs]} + in + let newRhs = { + pexp_loc = rhsLoc; + pexp_attributes = []; + pexp_desc = Pexp_apply (rhs, args) + } in + let allArgs = (Asttypes.Nolabel, newLhs)::[(Asttypes.Nolabel, newRhs)] in + {expr with pexp_desc = Pexp_apply (op, allArgs)} + | _ -> expr + +let makeReasonArityMapper ~forPrinter = + let open Ast_mapper in + { default_mapper with + expr = begin fun mapper expr -> + match expr with + (* Don't mind this case, Reason doesn't handle this. *) + (* | {pexp_desc = Pexp_variant (lbl, args); pexp_loc; pexp_attributes} -> *) + (* let newArgs = match args with *) + (* | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args-> *) + (* if forPrinter then args else Some sp *) + (* | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp *) + (* | _ -> args *) + (* in *) + (* default_mapper.expr mapper {pexp_desc=Pexp_variant(lbl, newArgs); pexp_loc; pexp_attributes} *) + | {pexp_desc=Pexp_construct(lid, args); pexp_loc; pexp_attributes} -> + let newArgs = match args with + | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args -> + if forPrinter then args else Some sp + | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp + | _ -> args + in + default_mapper.expr mapper { pexp_desc=Pexp_construct(lid, newArgs); pexp_loc; pexp_attributes} + | expr -> + default_mapper.expr mapper (rewriteReasonFastPipe expr) + end; + pat = begin fun mapper pattern -> + match pattern with + (* Don't mind this case, Reason doesn't handle this. *) + (* | {ppat_desc = Ppat_variant (lbl, args); ppat_loc; ppat_attributes} -> *) + (* let newArgs = match args with *) + (* | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> *) + (* if forPrinter then args else Some sp *) + (* | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp *) + (* | _ -> args *) + (* in *) + (* default_mapper.pat mapper {ppat_desc = Ppat_variant (lbl, newArgs); ppat_loc; ppat_attributes;} *) + | {ppat_desc=Ppat_construct(lid, args); + ppat_loc; + ppat_attributes} -> + let new_args = match args with + | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> + if forPrinter then args else Some sp + | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp + | _ -> args in + default_mapper.pat mapper { ppat_desc=Ppat_construct(lid, new_args); ppat_loc; ppat_attributes;} + | x -> default_mapper.pat mapper x + end; + } + +let escapeTemplateLiteral s = + let len = String.length s in + let b = Buffer.create len in + let i = ref 0 in + while !i < len do + let c = (String.get [@doesNotRaise]) s !i in + if c = '`' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '`'; + incr i; + ) else if c = '$' then ( + if !i + 1 < len then ( + let c2 = (String.get [@doesNotRaise]) s (!i + 1) in + if c2 = '{' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '$'; + Buffer.add_char b '{'; + ) else ( + Buffer.add_char b c; + Buffer.add_char b c2; + ); + i := !i + 2; + ) else ( + Buffer.add_char b c; + incr i + ) + ) else if c = '\\' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '\\'; + incr i; + ) else ( + Buffer.add_char b c; + incr i + ) + done; + Buffer.contents b + +let escapeStringContents s = + let len = String.length s in + let b = Buffer.create len in + + let i = ref 0 in + + while !i < len do + let c = String.unsafe_get s !i in + if c = '\\' then ( + incr i; + Buffer.add_char b c; + let c = String.unsafe_get s !i in + if !i < len then + let () = Buffer.add_char b c in + incr i + else + () + ) else if c = '"' then ( + Buffer.add_char b '\\'; + Buffer.add_char b c; + incr i; + ) else ( + Buffer.add_char b c; + incr i; + ) + done; + Buffer.contents b + +let looksLikeRecursiveTypeDeclaration typeDeclaration = + let open Parsetree in + let name = typeDeclaration.ptype_name.txt in + let rec checkKind kind = + match kind with + | Ptype_abstract | Ptype_open -> false + | Ptype_variant constructorDeclarations -> + List.exists checkConstructorDeclaration constructorDeclarations + | Ptype_record labelDeclarations -> + List.exists checkLabelDeclaration labelDeclarations + + and checkConstructorDeclaration constrDecl = + checkConstructorArguments constrDecl.pcd_args + || (match constrDecl.pcd_res with + | Some typexpr -> + checkTypExpr typexpr + | None -> false + ) + + and checkLabelDeclaration labelDeclaration = + checkTypExpr labelDeclaration.pld_type + + and checkConstructorArguments constrArg = + match constrArg with + | Pcstr_tuple types -> + List.exists checkTypExpr types + | Pcstr_record labelDeclarations -> + List.exists checkLabelDeclaration labelDeclarations + + and checkTypExpr typ = + match typ.ptyp_desc with + | Ptyp_any -> false + | Ptyp_var _ -> false + | Ptyp_object (fields, _) -> + List.exists checkObjectField fields + | Ptyp_class _ -> false + | Ptyp_package _ -> false + | Ptyp_extension _ -> false + | Ptyp_arrow (_lbl, typ1, typ2) -> + checkTypExpr typ1 || checkTypExpr typ2 + | Ptyp_tuple types -> + List.exists checkTypExpr types + | Ptyp_constr ({txt = longident}, types) -> + (match longident with + | Lident ident -> ident = name + | _ -> false + ) || + List.exists checkTypExpr types + | Ptyp_alias (typ, _) -> checkTypExpr typ + | Ptyp_variant (rowFields, _, _) -> + List.exists checkRowFields rowFields + | Ptyp_poly (_, typ) -> + checkTypExpr typ + + and checkObjectField field = match field with + | Otag (_label, _attrs, typ) -> checkTypExpr typ + | Oinherit typ -> checkTypExpr typ + + and checkRowFields rowField = + match rowField with + | Rtag (_, _, _, types) -> + List.exists checkTypExpr types + | Rinherit typexpr -> + checkTypExpr typexpr + + and checkManifest manifest = + match manifest with + | Some typ -> + checkTypExpr typ + | None -> false + in + checkKind typeDeclaration.ptype_kind || checkManifest typeDeclaration.ptype_manifest + + +let filterReasonRawLiteral attrs = + List.filter (fun attr -> + match attr with + | ({Location.txt = ("reason.raw_literal")}, _) -> false + | _ -> true + ) attrs + +let stringLiteralMapper stringData = + let isSameLocation l1 l2 = + let open Location in + l1.loc_start.pos_cnum == l2.loc_start.pos_cnum + in + let remainingStringData = stringData in + let open Ast_mapper in + { default_mapper with + expr = (fun mapper expr -> + match expr.pexp_desc with + | Pexp_constant (Pconst_string (_txt, None)) -> + begin match + List.find_opt (fun (_stringData, stringLoc) -> + isSameLocation stringLoc expr.pexp_loc + ) remainingStringData + with + | Some(stringData, _) -> + let stringData = + let attr = List.find_opt (fun attr -> match attr with + | ({Location.txt = ("reason.raw_literal")}, _) -> true + | _ -> false + ) expr.pexp_attributes in + match attr with + | Some (_, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (raw, _))}, _)}]) -> + raw + | _ -> (String.sub [@doesNotRaise]) stringData 1 (String.length stringData - 2) + in + {expr with + pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; + pexp_desc = Pexp_constant (Pconst_string (stringData, None)) + } + | None -> + default_mapper.expr mapper expr + end + | _ -> default_mapper.expr mapper expr + ) + } + +let hasUncurriedAttribute attrs = List.exists (fun attr -> match attr with + | ({Asttypes.txt = "bs"}, Parsetree.PStr []) -> true + | _ -> false +) attrs + +let normalize = + let open Ast_mapper in + { default_mapper with + extension = (fun mapper ext -> + match ext with + | (id, payload) -> + ( + {id with txt = Res_printer.convertBsExtension id.txt}, + default_mapper.payload mapper payload + ) + ); + attribute = (fun mapper attr -> + match attr with + | (id, payload) -> + ( + {id with txt = Res_printer.convertBsExternalAttribute id.txt}, + default_mapper.payload mapper payload + ) + ); + attributes = (fun mapper attrs -> + attrs + |> List.filter (fun attr -> + match attr with + | ({Location.txt = ( + "reason.preserve_braces" + | "explicit_arity" + | "implicity_arity" + )}, _) -> false + | _ ->true + ) + |> default_mapper.attributes mapper + ); + pat = begin fun mapper p -> + match p.ppat_desc with + | Ppat_open ({txt = longidentOpen}, pattern) -> + let p = rewritePpatOpen longidentOpen pattern in + default_mapper.pat mapper p + | Ppat_constant (Pconst_string (txt, tag)) -> + let newTag = match tag with + (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) + | Some "" -> Some "js" + | tag -> tag + in + let s = Parsetree.Pconst_string ((escapeTemplateLiteral txt), newTag) in + {p with + ppat_attributes = mapper.attributes mapper p.ppat_attributes; + ppat_desc = Ppat_constant s + } + | _ -> + default_mapper.pat mapper p + end; + typ = (fun mapper typ -> + match typ.ptyp_desc with + | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, [arg]) -> + (* Js.t({"a": b}) -> {"a": b} + Since compiler >9.0.1 objects don't need Js.t wrapping anymore *) + mapper.typ mapper arg + | _ -> default_mapper.typ mapper typ + ); + expr = (fun mapper expr -> + match expr.pexp_desc with + | Pexp_constant (Pconst_string (txt, None)) -> + let raw = escapeStringContents txt in + let s = Parsetree.Pconst_string (raw, None) in + {expr with pexp_desc = Pexp_constant s} + | Pexp_constant (Pconst_string (txt, tag)) -> + let newTag = match tag with + (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) + | Some "" -> Some "js" + | tag -> tag + in + let s = Parsetree.Pconst_string ((escapeTemplateLiteral txt), newTag) in + {expr with + pexp_attributes = mapper.attributes mapper expr.pexp_attributes; + pexp_desc = Pexp_constant s + } + | Pexp_apply ( + callExpr, + [ + Nolabel, + ({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); pexp_attributes = []} as unitExpr) + ] + ) when hasUncurriedAttribute expr.pexp_attributes + -> + {expr with + pexp_attributes = mapper.attributes mapper expr.pexp_attributes; + pexp_desc = Pexp_apply ( + callExpr, + [Nolabel, {unitExpr with pexp_loc = {unitExpr.pexp_loc with loc_ghost = true}}] + ) + } + | Pexp_function cases -> + let loc = match (cases, List.rev cases) with + | (first::_), (last::_) -> + {first.pc_lhs.ppat_loc with loc_end = last.pc_rhs.pexp_loc.loc_end} + | _ -> Location.none + in + let var = { + Parsetree.ppat_loc = Location.none; + ppat_attributes = []; + ppat_desc = Ppat_var (Location.mknoloc "x"); + } in + { + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = Pexp_fun ( + Asttypes.Nolabel, + None, + var, + { + pexp_loc = loc; + pexp_attributes = []; + pexp_desc = Pexp_match ( + { + pexp_loc = Location.none; + pexp_attributes = []; + pexp_desc = Pexp_ident (Location.mknoloc (Longident.Lident "x")) + }, + (mapper.cases mapper cases) + ) + + } + ) + } + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "!"}}, + [Asttypes.Nolabel, operand] + ) -> + (* turn `!foo` into `foo.contents` *) + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = Pexp_field (mapper.expr mapper operand, (Location.mknoloc (Longident.Lident "contents"))) + } + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [ + Asttypes.Nolabel, lhs; Nolabel, + ({pexp_desc = Pexp_constant (Pconst_string (txt, None)) | (Pexp_ident ({txt = Longident.Lident txt})); pexp_loc = labelLoc})] + ) -> + let label = Location.mkloc txt labelLoc in + { + pexp_loc = expr.pexp_loc; + pexp_attributes = expr.pexp_attributes; + pexp_desc = Pexp_send (mapper.expr mapper lhs, label) + } + | Pexp_match ( + condition, + [ + {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "true"}, None)}; pc_rhs = thenExpr }; + {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "false"}, None)}; pc_rhs = elseExpr }; + ] + ) -> + let ternaryMarker = (Location.mknoloc "ns.ternary", Parsetree.PStr []) in + {Parsetree.pexp_loc = expr.pexp_loc; + pexp_desc = Pexp_ifthenelse ( + mapper.expr mapper condition, + mapper.expr mapper thenExpr, + (Some (mapper.expr mapper elseExpr)) + ); + pexp_attributes = ternaryMarker::expr.pexp_attributes; + } + | _ -> default_mapper.expr mapper expr + ); + structure_item = begin fun mapper structureItem -> + match structureItem.pstr_desc with + (* heuristic: if we have multiple type declarations, mark them recursive *) + | Pstr_type (Recursive as recFlag, typeDeclarations) -> + let flag = match typeDeclarations with + | [td] -> + if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + {structureItem with pstr_desc = Pstr_type ( + flag, + List.map (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration + ) typeDeclarations + )} + | _ -> default_mapper.structure_item mapper structureItem + end; + signature_item = begin fun mapper signatureItem -> + match signatureItem.psig_desc with + (* heuristic: if we have multiple type declarations, mark them recursive *) + | Psig_type (Recursive as recFlag, typeDeclarations) -> + let flag = match typeDeclarations with + | [td] -> + if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive + else Asttypes.Nonrecursive + | _ -> recFlag + in + {signatureItem with psig_desc = Psig_type ( + flag, + List.map (fun typeDeclaration -> + default_mapper.type_declaration mapper typeDeclaration + ) typeDeclarations + )} + | _ -> default_mapper.signature_item mapper signatureItem + end; + value_binding = begin fun mapper vb -> + match vb with + | { + pvb_pat = {ppat_desc = Ppat_var _} as pat; + pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } + } when expr_loc.loc_ghost -> + (* let t: t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = { + Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ) + } in + {vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} + | { + pvb_pat = {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], _)})} ; + pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } + } when expr_loc.loc_ghost -> + (* let t: . t = (expr : t) -> let t: t = expr *) + let typ = default_mapper.typ mapper typ in + let pat = default_mapper.pat mapper pat in + let expr = mapper.expr mapper expr in + let newPattern = { + Parsetree.ppat_loc = {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; + ppat_attributes = []; + ppat_desc = Ppat_constraint (pat, typ) + } in + {vb with + pvb_pat = newPattern; + pvb_expr = expr; + pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} + | _ -> default_mapper.value_binding mapper vb + end; + } + +let normalizeReasonArityStructure ~forPrinter s = + let mapper = makeReasonArityMapper ~forPrinter in + mapper.Ast_mapper.structure mapper s + +let normalizeReasonAritySignature ~forPrinter s = + let mapper = makeReasonArityMapper ~forPrinter in + mapper.Ast_mapper.signature mapper s + +let structure s = normalize.Ast_mapper.structure normalize s +let signature s = normalize.Ast_mapper.signature normalize s + +let replaceStringLiteralStructure stringData structure = + let mapper = stringLiteralMapper stringData in + mapper.Ast_mapper.structure mapper structure + +let replaceStringLiteralSignature stringData signature = + let mapper = stringLiteralMapper stringData in + mapper.Ast_mapper.signature mapper signature diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_conversion.mli b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.mli new file mode 100644 index 000000000..f66f1965d --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_conversion.mli @@ -0,0 +1,24 @@ +(* The purpose of this module is to convert a parsetree coming from the reason + * or ocaml parser, into something consumable by the rescript printer. *) + +(* Ocaml/Reason parser interprets string literals: i.e. escape sequences and unicode. + * For printing purposes you want to preserve the original string. + * Example: "😎" is interpreted as "\240\159\152\142" + * The purpose of this routine is to place the original string back in + * the parsetree for printing purposes. Unicode and escape sequences + * shouldn't be mangled when *) +val replaceStringLiteralStructure: + (string * Location.t) list -> Parsetree.structure -> Parsetree.structure +val replaceStringLiteralSignature: + (string * Location.t) list -> Parsetree.signature -> Parsetree.signature + +(* Get rid of the explicit/implicit arity attributes *) +val normalizeReasonArityStructure: + forPrinter:bool -> Parsetree.structure -> Parsetree.structure +val normalizeReasonAritySignature: + forPrinter:bool -> Parsetree.signature -> Parsetree.signature + +(* transform parts of the parsetree into a suitable parsetree suitable + * for printing. Example: convert reason ternaries into rescript ternaries *) +val structure: Parsetree.structure -> Parsetree.structure +val signature: Parsetree.signature -> Parsetree.signature diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_debugger.ml b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.ml new file mode 100644 index 000000000..1dbb2d420 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.ml @@ -0,0 +1,1235 @@ +module Doc = Res_doc + +let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ structure -> + Printast.implementation Format.std_formatter structure + end; + printInterface = begin fun ~width:_ ~filename:_ ~comments:_ signature -> + Printast.interface Format.std_formatter signature + end; +} + +module Sexp: sig + type t + + val atom: string -> t + val list: t list -> t + val toString: t -> string +end = struct + type t = + | Atom of string + | List of t list + + let atom s = Atom s + let list l = List l + + let rec toDoc t = + match t with + | Atom s -> Doc.text s + | List [] -> Doc.text "()" + | List [sexpr] -> Doc.concat [Doc.lparen; toDoc sexpr; Doc.rparen;] + | List (hd::tail) -> + Doc.group ( + Doc.concat [ + Doc.lparen; + toDoc hd; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.line (List.map toDoc tail); + ] + ); + Doc.rparen; + ] + ) + + let toString sexpr = + let doc = toDoc sexpr in + Doc.toString ~width:80 doc +end + +module SexpAst = struct + open Parsetree + + let mapEmpty ~f items = + match items with + | [] -> [Sexp.list []] + | items -> List.map f items + + let string txt = + Sexp.atom ("\"" ^ txt ^ "\"") + + let char c = + Sexp.atom ("'" ^ (Char.escaped c) ^ "'") + + let optChar oc = + match oc with + | None -> Sexp.atom "None" + | Some c -> + Sexp.list [ + Sexp.atom "Some"; + char c + ] + + let longident l = + let rec loop l = match l with + | Longident.Lident ident -> Sexp.list [ + Sexp.atom "Lident"; + string ident; + ] + | Longident.Ldot (lident, txt) -> + Sexp.list [ + Sexp.atom "Ldot"; + loop lident; + string txt; + ] + | Longident.Lapply (l1, l2) -> + Sexp.list [ + Sexp.atom "Lapply"; + loop l1; + loop l2; + ] + in + Sexp.list [ + Sexp.atom "longident"; + loop l; + ] + + let closedFlag flag = match flag with + | Asttypes.Closed -> Sexp.atom "Closed" + | Open -> Sexp.atom "Open" + + let directionFlag flag = match flag with + | Asttypes.Upto -> Sexp.atom "Upto" + | Downto -> Sexp.atom "Downto" + + let recFlag flag = match flag with + | Asttypes.Recursive -> Sexp.atom "Recursive" + | Nonrecursive -> Sexp.atom "Nonrecursive" + + let overrideFlag flag = match flag with + | Asttypes.Override -> Sexp.atom "Override" + | Fresh -> Sexp.atom "Fresh" + + let privateFlag flag = match flag with + | Asttypes.Public -> Sexp.atom "Public" + | Private -> Sexp.atom "Private" + + let mutableFlag flag = match flag with + | Asttypes.Immutable -> Sexp.atom "Immutable" + | Mutable -> Sexp.atom "Mutable" + + let variance v = match v with + | Asttypes.Covariant -> Sexp.atom "Covariant" + | Contravariant -> Sexp.atom "Contravariant" + | Invariant -> Sexp.atom "Invariant" + + let argLabel lbl = match lbl with + | Asttypes.Nolabel -> Sexp.atom "Nolabel" + | Labelled txt -> Sexp.list [ + Sexp.atom "Labelled"; + string txt; + ] + | Optional txt -> Sexp.list [ + Sexp.atom "Optional"; + string txt; + ] + + let constant c = + let sexpr = match c with + | Pconst_integer (txt, tag) -> + Sexp.list [ + Sexp.atom "Pconst_integer"; + string txt; + optChar tag; + ] + | Pconst_char c -> + Sexp.list [ + Sexp.atom "Pconst_char"; + Sexp.atom (Char.escaped c); + ] + | Pconst_string (txt, tag) -> + Sexp.list [ + Sexp.atom "Pconst_string"; + string txt; + match tag with + | Some txt -> Sexp.list [ + Sexp.atom "Some"; + string txt; + ] + | None -> Sexp.atom "None"; + ] + | Pconst_float (txt, tag) -> + Sexp.list [ + Sexp.atom "Pconst_float"; + string txt; + optChar tag; + ] + in + Sexp.list [ + Sexp.atom "constant"; + sexpr + ] + + let rec structure s = + Sexp.list ( + (Sexp.atom "structure")::(List.map structureItem s) + ) + + and structureItem si = + let desc = match si.pstr_desc with + | Pstr_eval (expr, attrs) -> + Sexp.list [ + Sexp.atom "Pstr_eval"; + expression expr; + attributes attrs; + ] + | Pstr_value (flag, vbs) -> + Sexp.list [ + Sexp.atom "Pstr_value"; + recFlag flag; + Sexp.list (mapEmpty ~f:valueBinding vbs) + ] + | Pstr_primitive (vd) -> + Sexp.list [ + Sexp.atom "Pstr_primitive"; + valueDescription vd; + ] + | Pstr_type (flag, tds) -> + Sexp.list [ + Sexp.atom "Pstr_type"; + recFlag flag; + Sexp.list (mapEmpty ~f:typeDeclaration tds) + ] + | Pstr_typext typext -> + Sexp.list [ + Sexp.atom "Pstr_type"; + typeExtension typext; + ] + | Pstr_exception ec -> + Sexp.list [ + Sexp.atom "Pstr_exception"; + extensionConstructor ec; + ] + | Pstr_module mb -> + Sexp.list [ + Sexp.atom "Pstr_module"; + moduleBinding mb; + ] + | Pstr_recmodule mbs -> + Sexp.list [ + Sexp.atom "Pstr_recmodule"; + Sexp.list (mapEmpty ~f:moduleBinding mbs); + ] + | Pstr_modtype modTypDecl -> + Sexp.list [ + Sexp.atom "Pstr_modtype"; + moduleTypeDeclaration modTypDecl; + ] + | Pstr_open openDesc -> + Sexp.list [ + Sexp.atom "Pstr_open"; + openDescription openDesc; + ] + | Pstr_class _ -> Sexp.atom "Pstr_class" + | Pstr_class_type _ -> Sexp.atom "Pstr_class_type" + | Pstr_include id -> + Sexp.list [ + Sexp.atom "Pstr_include"; + includeDeclaration id; + ] + | Pstr_attribute attr -> + Sexp.list [ + Sexp.atom "Pstr_attribute"; + attribute attr; + ] + | Pstr_extension (ext, attrs) -> + Sexp.list [ + Sexp.atom "Pstr_extension"; + extension ext; + attributes attrs; + ] + in + Sexp.list [ + Sexp.atom "structure_item"; + desc; + ] + + and includeDeclaration id = + Sexp.list [ + Sexp.atom "include_declaration"; + moduleExpression id.pincl_mod; + attributes id.pincl_attributes; + ] + + and openDescription od = + Sexp.list [ + Sexp.atom "open_description"; + longident od.popen_lid.Asttypes.txt; + attributes od.popen_attributes; + ] + + and moduleTypeDeclaration mtd = + Sexp.list [ + Sexp.atom "module_type_declaration"; + string mtd.pmtd_name.Asttypes.txt; + (match mtd.pmtd_type with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [ + Sexp.atom "Some"; + moduleType modType; + ]); + attributes mtd.pmtd_attributes; + ] + + and moduleBinding mb = + Sexp.list [ + Sexp.atom "module_binding"; + string mb.pmb_name.Asttypes.txt; + moduleExpression mb.pmb_expr; + attributes mb.pmb_attributes; + ] + + and moduleExpression me = + let desc = match me.pmod_desc with + | Pmod_ident modName -> + Sexp.list [ + Sexp.atom "Pmod_ident"; + longident modName.Asttypes.txt; + ] + | Pmod_structure s -> + Sexp.list [ + Sexp.atom "Pmod_structure"; + structure s; + ] + | Pmod_functor (lbl, optModType, modExpr) -> + Sexp.list [ + Sexp.atom "Pmod_functor"; + string lbl.Asttypes.txt; + (match optModType with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [ + Sexp.atom "Some"; + moduleType modType; + ]); + moduleExpression modExpr; + ] + | Pmod_apply (callModExpr, modExprArg) -> + Sexp.list [ + Sexp.atom "Pmod_apply"; + moduleExpression callModExpr; + moduleExpression modExprArg; + ] + | Pmod_constraint (modExpr, modType) -> + Sexp.list [ + Sexp.atom "Pmod_constraint"; + moduleExpression modExpr; + moduleType modType; + ] + | Pmod_unpack expr -> + Sexp.list [ + Sexp.atom "Pmod_unpack"; + expression expr; + ] + | Pmod_extension ext -> + Sexp.list [ + Sexp.atom "Pmod_extension"; + extension ext; + ] + in + Sexp.list [ + Sexp.atom "module_expr"; + desc; + attributes me.pmod_attributes; + ] + + and moduleType mt = + let desc = match mt.pmty_desc with + | Pmty_ident longidentLoc -> + Sexp.list [ + Sexp.atom "Pmty_ident"; + longident longidentLoc.Asttypes.txt; + ] + | Pmty_signature s -> + Sexp.list [ + Sexp.atom "Pmty_signature"; + signature s; + ] + | Pmty_functor (lbl, optModType, modType) -> + Sexp.list [ + Sexp.atom "Pmty_functor"; + string lbl.Asttypes.txt; + (match optModType with + | None -> Sexp.atom "None" + | Some modType -> Sexp.list [ + Sexp.atom "Some"; + moduleType modType; + ]); + moduleType modType; + ] + | Pmty_alias longidentLoc -> + Sexp.list [ + Sexp.atom "Pmty_alias"; + longident longidentLoc.Asttypes.txt; + ] + | Pmty_extension ext -> + Sexp.list [ + Sexp.atom "Pmty_extension"; + extension ext; + ] + | Pmty_typeof modExpr -> + Sexp.list [ + Sexp.atom "Pmty_typeof"; + moduleExpression modExpr; + ] + | Pmty_with (modType, withConstraints) -> + Sexp.list [ + Sexp.atom "Pmty_with"; + moduleType modType; + Sexp.list (mapEmpty ~f:withConstraint withConstraints); + ] + in + Sexp.list [ + Sexp.atom "module_type"; + desc; + attributes mt.pmty_attributes; + ] + + and withConstraint wc = match wc with + | Pwith_type (longidentLoc, td) -> + Sexp.list [ + Sexp.atom "Pmty_with"; + longident longidentLoc.Asttypes.txt; + typeDeclaration td; + ] + | Pwith_module (l1, l2) -> + Sexp.list [ + Sexp.atom "Pwith_module"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] + | Pwith_typesubst (longidentLoc, td) -> + Sexp.list [ + Sexp.atom "Pwith_typesubst"; + longident longidentLoc.Asttypes.txt; + typeDeclaration td; + ] + | Pwith_modsubst (l1, l2) -> + Sexp.list [ + Sexp.atom "Pwith_modsubst"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] + + and signature s = + Sexp.list ( + (Sexp.atom "signature")::(List.map signatureItem s) + ) + + and signatureItem si = + let descr = match si.psig_desc with + | Psig_value vd -> + Sexp.list [ + Sexp.atom "Psig_value"; + valueDescription vd; + ] + | Psig_type (flag, typeDeclarations) -> + Sexp.list [ + Sexp.atom "Psig_type"; + recFlag flag; + Sexp.list (mapEmpty ~f:typeDeclaration typeDeclarations); + ] + | Psig_typext typExt -> + Sexp.list [ + Sexp.atom "Psig_typext"; + typeExtension typExt; + ] + | Psig_exception extConstr -> + Sexp.list [ + Sexp.atom "Psig_exception"; + extensionConstructor extConstr; + ] + | Psig_module modDecl -> + Sexp.list [ + Sexp.atom "Psig_module"; + moduleDeclaration modDecl; + ] + | Psig_recmodule modDecls -> + Sexp.list [ + Sexp.atom "Psig_recmodule"; + Sexp.list (mapEmpty ~f:moduleDeclaration modDecls); + ] + | Psig_modtype modTypDecl -> + Sexp.list [ + Sexp.atom "Psig_modtype"; + moduleTypeDeclaration modTypDecl; + ] + | Psig_open openDesc -> + Sexp.list [ + Sexp.atom "Psig_open"; + openDescription openDesc; + ] + | Psig_include inclDecl -> + Sexp.list [ + Sexp.atom "Psig_include"; + includeDescription inclDecl + ] + | Psig_class _ -> Sexp.list [Sexp.atom "Psig_class";] + | Psig_class_type _ -> Sexp.list [ Sexp.atom "Psig_class_type"; ] + | Psig_attribute attr -> + Sexp.list [ + Sexp.atom "Psig_attribute"; + attribute attr; + ] + | Psig_extension (ext, attrs) -> + Sexp.list [ + Sexp.atom "Psig_extension"; + extension ext; + attributes attrs; + ] + in + Sexp.list [ + Sexp.atom "signature_item"; + descr; + ] + + and includeDescription id = + Sexp.list [ + Sexp.atom "include_description"; + moduleType id.pincl_mod; + attributes id.pincl_attributes; + ] + + and moduleDeclaration md = + Sexp.list [ + Sexp.atom "module_declaration"; + string md.pmd_name.Asttypes.txt; + moduleType md.pmd_type; + attributes md.pmd_attributes; + ] + + and valueBinding vb = + Sexp.list [ + Sexp.atom "value_binding"; + pattern vb.pvb_pat; + expression vb.pvb_expr; + attributes vb.pvb_attributes; + ] + + and valueDescription vd = + Sexp.list [ + Sexp.atom "value_description"; + string vd.pval_name.Asttypes.txt; + coreType vd.pval_type; + Sexp.list (mapEmpty ~f:string vd.pval_prim); + attributes vd.pval_attributes; + ] + + and typeDeclaration td = + Sexp.list [ + Sexp.atom "type_declaration"; + string td.ptype_name.Asttypes.txt; + Sexp.list [ + Sexp.atom "ptype_params"; + Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> + Sexp.list [ + coreType typexpr; + variance var; + ]) td.ptype_params) + ]; + Sexp.list [ + Sexp.atom "ptype_cstrs"; + Sexp.list (mapEmpty ~f:(fun (typ1, typ2, _loc) -> + Sexp.list [ + coreType typ1; + coreType typ2; + ]) td.ptype_cstrs) + ]; + Sexp.list [ + Sexp.atom "ptype_kind"; + typeKind td.ptype_kind; + ]; + Sexp.list [ + Sexp.atom "ptype_manifest"; + match td.ptype_manifest with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ] + ]; + Sexp.list [ + Sexp.atom "ptype_private"; + privateFlag td.ptype_private; + ]; + attributes td.ptype_attributes; + ] + + and extensionConstructor ec = + Sexp.list [ + Sexp.atom "extension_constructor"; + string ec.pext_name.Asttypes.txt; + extensionConstructorKind ec.pext_kind; + attributes ec.pext_attributes; + ] + + and extensionConstructorKind kind = match kind with + | Pext_decl (args, optTypExpr) -> + Sexp.list [ + Sexp.atom "Pext_decl"; + constructorArguments args; + match optTypExpr with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ] + ] + | Pext_rebind longidentLoc -> + Sexp.list [ + Sexp.atom "Pext_rebind"; + longident longidentLoc.Asttypes.txt; + ] + + and typeExtension te = + Sexp.list [ + Sexp.atom "type_extension"; + Sexp.list [ + Sexp.atom "ptyext_path"; + longident te.ptyext_path.Asttypes.txt; + ]; + Sexp.list [ + Sexp.atom "ptyext_parms"; + Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> + Sexp.list [ + coreType typexpr; + variance var; + ]) te.ptyext_params) + ]; + Sexp.list [ + Sexp.atom "ptyext_constructors"; + Sexp.list (mapEmpty ~f:extensionConstructor te.ptyext_constructors); + ]; + Sexp.list [ + Sexp.atom "ptyext_private"; + privateFlag te.ptyext_private; + ]; + attributes te.ptyext_attributes; + ] + + and typeKind kind = match kind with + | Ptype_abstract -> Sexp.atom "Ptype_abstract" + | Ptype_variant constrDecls -> + Sexp.list [ + Sexp.atom "Ptype_variant"; + Sexp.list (mapEmpty ~f:constructorDeclaration constrDecls); + ] + | Ptype_record lblDecls -> + Sexp.list [ + Sexp.atom "Ptype_record"; + Sexp.list (mapEmpty ~f:labelDeclaration lblDecls); + ] + | Ptype_open -> Sexp.atom "Ptype_open" + + and constructorDeclaration cd = + Sexp.list [ + Sexp.atom "constructor_declaration"; + string cd.pcd_name.Asttypes.txt; + Sexp.list [ + Sexp.atom "pcd_args"; + constructorArguments cd.pcd_args; + ]; + Sexp.list [ + Sexp.atom "pcd_res"; + match cd.pcd_res with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ] + ]; + attributes cd.pcd_attributes; + ] + + and constructorArguments args = match args with + | Pcstr_tuple types -> + Sexp.list [ + Sexp.atom "Pcstr_tuple"; + Sexp.list (mapEmpty ~f:coreType types) + ] + | Pcstr_record lds -> + Sexp.list [ + Sexp.atom "Pcstr_record"; + Sexp.list (mapEmpty ~f:labelDeclaration lds) + ] + + and labelDeclaration ld = + Sexp.list [ + Sexp.atom "label_declaration"; + string ld.pld_name.Asttypes.txt; + mutableFlag ld.pld_mutable; + coreType ld.pld_type; + attributes ld.pld_attributes; + ] + + and expression expr = + let desc = match expr.pexp_desc with + | Pexp_ident longidentLoc -> + Sexp.list [ + Sexp.atom "Pexp_ident"; + longident longidentLoc.Asttypes.txt; + ] + | Pexp_constant c -> + Sexp.list [ + Sexp.atom "Pexp_constant"; + constant c + ] + | Pexp_let (flag, vbs, expr) -> + Sexp.list [ + Sexp.atom "Pexp_let"; + recFlag flag; + Sexp.list (mapEmpty ~f:valueBinding vbs); + expression expr; + ] + | Pexp_function cases -> + Sexp.list [ + Sexp.atom "Pexp_function"; + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_fun (argLbl, exprOpt, pat, expr) -> + Sexp.list [ + Sexp.atom "Pexp_fun"; + argLabel argLbl; + (match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [ + Sexp.atom "Some"; + expression expr; + ]); + pattern pat; + expression expr; + ] + | Pexp_apply (expr, args) -> + Sexp.list [ + Sexp.atom "Pexp_apply"; + expression expr; + Sexp.list (mapEmpty ~f:(fun (argLbl, expr) -> Sexp.list [ + argLabel argLbl; + expression expr + ]) args); + ] + | Pexp_match (expr, cases) -> + Sexp.list [ + Sexp.atom "Pexp_match"; + expression expr; + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_try (expr, cases) -> + Sexp.list [ + Sexp.atom "Pexp_try"; + expression expr; + Sexp.list (mapEmpty ~f:case cases); + ] + | Pexp_tuple exprs -> + Sexp.list [ + Sexp.atom "Pexp_tuple"; + Sexp.list (mapEmpty ~f:expression exprs); + ] + | Pexp_construct (longidentLoc, exprOpt) -> + Sexp.list [ + Sexp.atom "Pexp_construct"; + longident longidentLoc.Asttypes.txt; + match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + ] + | Pexp_variant (lbl, exprOpt) -> + Sexp.list [ + Sexp.atom "Pexp_variant"; + string lbl; + match exprOpt with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + ] + | Pexp_record (rows, optExpr) -> + Sexp.list [ + Sexp.atom "Pexp_record"; + Sexp.list (mapEmpty ~f:(fun (longidentLoc, expr) -> Sexp.list [ + longident longidentLoc.Asttypes.txt; + expression expr; + ]) rows); + (match optExpr with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ]); + ] + | Pexp_field (expr, longidentLoc) -> + Sexp.list [ + Sexp.atom "Pexp_field"; + expression expr; + longident longidentLoc.Asttypes.txt; + ] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + Sexp.list [ + Sexp.atom "Pexp_setfield"; + expression expr1; + longident longidentLoc.Asttypes.txt; + expression expr2; + ] + | Pexp_array exprs -> + Sexp.list [ + Sexp.atom "Pexp_array"; + Sexp.list (mapEmpty ~f:expression exprs); + ] + | Pexp_ifthenelse (expr1, expr2, optExpr) -> + Sexp.list [ + Sexp.atom "Pexp_ifthenelse"; + expression expr1; + expression expr2; + (match optExpr with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [ + Sexp.atom "Some"; + expression expr; + ]); + ] + | Pexp_sequence (expr1, expr2) -> + Sexp.list [ + Sexp.atom "Pexp_sequence"; + expression expr1; + expression expr2; + ] + | Pexp_while (expr1, expr2) -> + Sexp.list [ + Sexp.atom "Pexp_while"; + expression expr1; + expression expr2; + ] + | Pexp_for (pat, e1, e2, flag, e3) -> + Sexp.list [ + Sexp.atom "Pexp_for"; + pattern pat; + expression e1; + expression e2; + directionFlag flag; + expression e3; + ] + | Pexp_constraint (expr, typexpr) -> + Sexp.list [ + Sexp.atom "Pexp_constraint"; + expression expr; + coreType typexpr; + ] + | Pexp_coerce (expr, optTyp, typexpr) -> + Sexp.list [ + Sexp.atom "Pexp_coerce"; + expression expr; + (match optTyp with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [ + Sexp.atom "Some"; + coreType typ; + ]); + coreType typexpr; + ] + | Pexp_send _ -> + Sexp.list [ + Sexp.atom "Pexp_send"; + ] + | Pexp_new _ -> + Sexp.list [ + Sexp.atom "Pexp_new"; + ] + | Pexp_setinstvar _ -> + Sexp.list [ + Sexp.atom "Pexp_setinstvar"; + ] + | Pexp_override _ -> + Sexp.list [ + Sexp.atom "Pexp_override"; + ] + | Pexp_letmodule (modName, modExpr, expr) -> + Sexp.list [ + Sexp.atom "Pexp_letmodule"; + string modName.Asttypes.txt; + moduleExpression modExpr; + expression expr; + ] + | Pexp_letexception (extConstr, expr) -> + Sexp.list [ + Sexp.atom "Pexp_letexception"; + extensionConstructor extConstr; + expression expr; + ] + | Pexp_assert expr -> + Sexp.list [ + Sexp.atom "Pexp_assert"; + expression expr; + ] + | Pexp_lazy expr -> + Sexp.list [ + Sexp.atom "Pexp_lazy"; + expression expr; + ] + | Pexp_poly _ -> + Sexp.list [ + Sexp.atom "Pexp_poly"; + ] + | Pexp_object _ -> + Sexp.list [ + Sexp.atom "Pexp_object"; + ] + | Pexp_newtype (lbl, expr) -> + Sexp.list [ + Sexp.atom "Pexp_newtype"; + string lbl.Asttypes.txt; + expression expr; + ] + | Pexp_pack modExpr -> + Sexp.list [ + Sexp.atom "Pexp_pack"; + moduleExpression modExpr; + ] + | Pexp_open (flag, longidentLoc, expr) -> + Sexp.list [ + Sexp.atom "Pexp_open"; + overrideFlag flag; + longident longidentLoc.Asttypes.txt; + expression expr; + ] + | Pexp_extension ext -> + Sexp.list [ + Sexp.atom "Pexp_extension"; + extension ext; + ] + | Pexp_unreachable -> Sexp.atom "Pexp_unreachable" + in + Sexp.list [ + Sexp.atom "expression"; + desc; + ] + + and case c = + Sexp.list [ + Sexp.atom "case"; + Sexp.list [ + Sexp.atom "pc_lhs"; + pattern c.pc_lhs; + ]; + Sexp.list [ + Sexp.atom "pc_guard"; + match c.pc_guard with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + ]; + Sexp.list [ + Sexp.atom "pc_rhs"; + expression c.pc_rhs; + ] + ] + + and pattern p = + let descr = match p.ppat_desc with + | Ppat_any -> + Sexp.atom "Ppat_any" + | Ppat_var var -> + Sexp.list [ + Sexp.atom "Ppat_var"; + string var.Location.txt; + ] + | Ppat_alias (p, alias) -> + Sexp.list [ + Sexp.atom "Ppat_alias"; + pattern p; + string alias.txt; + ] + | Ppat_constant c -> + Sexp.list [ + Sexp.atom "Ppat_constant"; + constant c; + ] + | Ppat_interval (lo, hi) -> + Sexp.list [ + Sexp.atom "Ppat_interval"; + constant lo; + constant hi; + ] + | Ppat_tuple (patterns) -> + Sexp.list [ + Sexp.atom "Ppat_tuple"; + Sexp.list (mapEmpty ~f:pattern patterns); + ] + | Ppat_construct (longidentLoc, optPattern) -> + Sexp.list [ + Sexp.atom "Ppat_construct"; + longident longidentLoc.Location.txt; + match optPattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [ + Sexp.atom "some"; + pattern p; + ] + ] + | Ppat_variant (lbl, optPattern) -> + Sexp.list [ + Sexp.atom "Ppat_variant"; + string lbl; + match optPattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [ + Sexp.atom "Some"; + pattern p; + ] + ] + | Ppat_record (rows, flag) -> + Sexp.list [ + Sexp.atom "Ppat_record"; + closedFlag flag; + Sexp.list (mapEmpty ~f:(fun (longidentLoc, p) -> + Sexp.list [ + longident longidentLoc.Location.txt; + pattern p; + ] + ) rows) + ] + | Ppat_array patterns -> + Sexp.list [ + Sexp.atom "Ppat_array"; + Sexp.list (mapEmpty ~f:pattern patterns); + ] + | Ppat_or (p1, p2) -> + Sexp.list [ + Sexp.atom "Ppat_or"; + pattern p1; + pattern p2; + ] + | Ppat_constraint (p, typexpr) -> + Sexp.list [ + Sexp.atom "Ppat_constraint"; + pattern p; + coreType typexpr; + ] + | Ppat_type longidentLoc -> + Sexp.list [ + Sexp.atom "Ppat_type"; + longident longidentLoc.Location.txt + ] + | Ppat_lazy p -> + Sexp.list [ + Sexp.atom "Ppat_lazy"; + pattern p; + ] + | Ppat_unpack stringLoc -> + Sexp.list [ + Sexp.atom "Ppat_unpack"; + string stringLoc.Location.txt; + ] + | Ppat_exception p -> + Sexp.list [ + Sexp.atom "Ppat_exception"; + pattern p; + ] + | Ppat_extension ext -> + Sexp.list [ + Sexp.atom "Ppat_extension"; + extension ext; + ] + | Ppat_open (longidentLoc, p) -> + Sexp.list [ + Sexp.atom "Ppat_open"; + longident longidentLoc.Location.txt; + pattern p; + ] + in + Sexp.list [ + Sexp.atom "pattern"; + descr; + ] + + and objectField field = match field with + | Otag (lblLoc, attrs, typexpr) -> + Sexp.list [ + Sexp.atom "Otag"; + string lblLoc.txt; + attributes attrs; + coreType typexpr; + ] + | Oinherit typexpr -> + Sexp.list [ + Sexp.atom "Oinherit"; + coreType typexpr; + ] + + and rowField field = match field with + | Rtag (labelLoc, attrs, truth, types) -> + Sexp.list [ + Sexp.atom "Rtag"; + string labelLoc.txt; + attributes attrs; + Sexp.atom (if truth then "true" else "false"); + Sexp.list (mapEmpty ~f:coreType types); + ] + | Rinherit typexpr -> + Sexp.list [ + Sexp.atom "Rinherit"; + coreType typexpr; + ] + + and packageType (modNameLoc, packageConstraints) = + Sexp.list [ + Sexp.atom "package_type"; + longident modNameLoc.Asttypes.txt; + Sexp.list (mapEmpty ~f:(fun (modNameLoc, typexpr) -> + Sexp.list [ + longident modNameLoc.Asttypes.txt; + coreType typexpr; + ] + ) packageConstraints) + ] + + and coreType typexpr = + let desc = match typexpr.ptyp_desc with + | Ptyp_any -> Sexp.atom "Ptyp_any" + | Ptyp_var var -> Sexp.list [ + Sexp.atom "Ptyp_var"; + string var + ] + | Ptyp_arrow (argLbl, typ1, typ2) -> + Sexp.list [ + Sexp.atom "Ptyp_arrow"; + argLabel argLbl; + coreType typ1; + coreType typ2; + ] + | Ptyp_tuple types -> + Sexp.list [ + Sexp.atom "Ptyp_tuple"; + Sexp.list (mapEmpty ~f:coreType types); + ] + | Ptyp_constr (longidentLoc, types) -> + Sexp.list [ + Sexp.atom "Ptyp_constr"; + longident longidentLoc.txt; + Sexp.list (mapEmpty ~f:coreType types); + ] + | Ptyp_alias (typexpr, alias) -> + Sexp.list [ + Sexp.atom "Ptyp_alias"; + coreType typexpr; + string alias; + ] + | Ptyp_object (fields, flag) -> + Sexp.list [ + Sexp.atom "Ptyp_object"; + closedFlag flag; + Sexp.list (mapEmpty ~f:objectField fields) + ] + | Ptyp_class (longidentLoc, types) -> + Sexp.list [ + Sexp.atom "Ptyp_class"; + longident longidentLoc.Location.txt; + Sexp.list (mapEmpty ~f:coreType types) + ] + | Ptyp_variant (fields, flag, optLabels) -> + Sexp.list [ + Sexp.atom "Ptyp_variant"; + Sexp.list (mapEmpty ~f:rowField fields); + closedFlag flag; + match optLabels with + | None -> Sexp.atom "None" + | Some lbls -> Sexp.list (mapEmpty ~f:string lbls); + ] + | Ptyp_poly (lbls, typexpr) -> + Sexp.list [ + Sexp.atom "Ptyp_poly"; + Sexp.list (mapEmpty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); + coreType typexpr; + ] + | Ptyp_package (package) -> + Sexp.list [ + Sexp.atom "Ptyp_package"; + packageType package; + ] + | Ptyp_extension (ext) -> + Sexp.list [ + Sexp.atom "Ptyp_extension"; + extension ext; + ] + in + Sexp.list [ + Sexp.atom "core_type"; + desc; + ] + + and payload p = + match p with + | PStr s -> + Sexp.list ( + (Sexp.atom "PStr")::(mapEmpty ~f:structureItem s) + ) + | PSig s -> + Sexp.list [ + Sexp.atom "PSig"; + signature s; + ] + | PTyp ct -> + Sexp.list [ + Sexp.atom "PTyp"; + coreType ct + ] + | PPat (pat, optExpr) -> + Sexp.list [ + Sexp.atom "PPat"; + pattern pat; + match optExpr with + | Some expr -> Sexp.list [ + Sexp.atom "Some"; + expression expr; + ] + | None -> Sexp.atom "None"; + ] + + and attribute (stringLoc, p) = + Sexp.list [ + Sexp.atom "attribute"; + Sexp.atom stringLoc.Asttypes.txt; + payload p; + ] + + and extension (stringLoc, p) = + Sexp.list [ + Sexp.atom "extension"; + Sexp.atom stringLoc.Asttypes.txt; + payload p; + ] + + and attributes attrs = + let sexprs = mapEmpty ~f:attribute attrs in + Sexp.list ((Sexp.atom "attributes")::sexprs) + + let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> structure |> Sexp.toString |> print_string + end; + printInterface = begin fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> signature |> Sexp.toString |> print_string + end; + } +end + +let sexpPrintEngine = SexpAst.printEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_ast_debugger.mli b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.mli new file mode 100644 index 000000000..392113312 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_ast_debugger.mli @@ -0,0 +1,8 @@ + + + +val printEngine : Res_driver.printEngine + + +val sexpPrintEngine : Res_driver.printEngine + diff --git a/analysis/src/vendor/res_outcome_printer/res_cli.ml b/analysis/src/vendor/res_outcome_printer/res_cli.ml new file mode 100644 index 000000000..5ec9875ce --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_cli.ml @@ -0,0 +1,296 @@ +(* + This CLI isn't used apart for this repo's testing purposes. The syntax + itself is used by ReScript's compiler programmatically through various other apis. +*) + +(* + This is OCaml's Misc.ml's Color module. More specifically, this is + ReScript's OCaml fork's Misc.ml's Color module: + https://github.com/rescript-lang/ocaml/blob/92e58bedced8d7e3e177677800a38922327ab860/utils/misc.ml#L540 + + The syntax's printing's coloring logic depends on: + 1. a global mutable variable that's set in the compiler: Misc.Color.color_enabled + 2. the colors tags supported by Misc.Color, e.g. style_of_tag, which Format + tags like @{hello@} use + 3. etc. + + When this syntax is programmatically used inside ReScript, the various + Format tags like and get properly colored depending on the + above points. + + But when used by this cli file, that coloring logic doesn't render properly + because we're compiling against vanilla OCaml 4.06 instead of ReScript's + OCaml fork. For example, the vanilla compiler doesn't support the `dim` + color (grey). So we emulate the right coloring logic by copy pasting how our + forked OCaml compiler does it. +*) +module Color = struct + (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) + type color = + | Black [@live] + | Red + | Green [@live] + | Yellow + | Blue [@live] + | Magenta + | Cyan + | White [@live] + ;; + + type style = + | FG of color (* foreground *) + | BG of color [@live] (* background *) + | Bold + | Reset + | Dim + + let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" + + let code_of_style = function + | FG c -> "3" ^ ansi_of_color c + | BG c -> "4" ^ ansi_of_color c + | Bold -> "1" + | Reset -> "0" + | Dim -> "2" + + let ansi_of_style_l l = + let s = match l with + | [] -> code_of_style Reset + | [s] -> code_of_style s + | _ -> String.concat ";" (List.map code_of_style l) + in + "\x1b[" ^ s ^ "m" + + type styles = { + error: style list; + warning: style list; + loc: style list; + } + + let default_styles = { + warning = [Bold; FG Magenta]; + error = [Bold; FG Red]; + loc = [Bold]; + } + + let cur_styles = ref default_styles + (* let get_styles () = !cur_styles *) + (* let set_styles s = cur_styles := s *) + + (* map a tag to a style, if the tag is known. + @raise Not_found otherwise *) + let style_of_tag s = match s with + | "error" -> (!cur_styles).error + | "warning" -> (!cur_styles).warning + | "loc" -> (!cur_styles).loc + | "info" -> [Bold; FG Yellow] + | "dim" -> [Dim] + | "filename" -> [FG Cyan] + | _ -> raise Not_found + [@@raises Not_found] + + let color_enabled = ref true + + (* either prints the tag of [s] or delegates to [or_else] *) + let mark_open_tag ~or_else s = + try + let style = style_of_tag s in + if !color_enabled then ansi_of_style_l style else "" + with Not_found -> or_else s + + let mark_close_tag ~or_else s = + try + let _ = style_of_tag s in + if !color_enabled then ansi_of_style_l [Reset] else "" + with Not_found -> or_else s + + (* add color handling to formatter [ppf] *) + let set_color_tag_handling ppf = + let open Format in + let functions = pp_get_formatter_tag_functions ppf () in + let functions' = {functions with + mark_open_tag=(mark_open_tag ~or_else:functions.mark_open_tag); + mark_close_tag=(mark_close_tag ~or_else:functions.mark_close_tag); + } in + pp_set_mark_tags ppf true; (* enable tags *) + pp_set_formatter_tag_functions ppf functions'; + (* also setup margins *) + pp_set_margin ppf (pp_get_margin std_formatter()); + () + + external isatty : out_channel -> bool = "caml_sys_isatty" + + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" + && term <> "" + && isatty stderr + + type setting = Auto [@live] | Always [@live] | Never [@live] + + let setup = + let first = ref true in (* initialize only once *) + let formatter_l = + [Format.std_formatter; Format.err_formatter; Format.str_formatter] + in + fun o -> + if !first then ( + first := false; + Format.set_mark_tags true; + List.iter set_color_tag_handling formatter_l; + color_enabled := (match o with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()) + ); + () +end + +(* command line flags *) +module ResClflags: sig + val recover: bool ref + val print: string ref + val width: int ref + val origin: string ref + val file: string ref + val interface: bool ref + val ppx: string ref + + val parse: unit -> unit +end = struct + let recover = ref false + let width = ref 100 + + let print = ref "res" + let origin = ref "" + let interface = ref false + let ppx = ref "" + let file = ref "" + + let usage = "\n**This command line is for the repo developer's testing purpose only. DO NOT use it in production**!\n\n" ^ + "Usage:\n rescript \n\n" ^ + "Examples:\n" ^ + " rescript myFile.res\n" ^ + " rescript -parse ml -print res myFile.ml\n" ^ + " rescript -parse res -print binary -interface myFile.resi\n\n" ^ + "Options are:" + + let spec = [ + ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); + ("-parse", Arg.String (fun txt -> origin := txt), "Parse reasonBinary, ml or res. Default: res"); + ("-print", Arg.String (fun txt -> print := txt), "Print either binary, ml, ast, sexp or res. Default: res"); + ("-width", Arg.Int (fun w -> width := w), "Specify the line length for the printer (formatter)"); + ("-interface", Arg.Unit (fun () -> interface := true), "Parse as interface"); + ("-ppx", Arg.String (fun txt -> ppx := txt), "Apply a specific built-in ppx before parsing, none or jsx. Default: none"); + ] + + let parse () = Arg.parse spec (fun f -> file := f) usage +end + +module CliArgProcessor = struct + type backend = Parser: ('diagnostics) Res_driver.parsingEngine -> backend [@@unboxed] + + let processFile ~isInterface ~width ~recover ~origin ~target ~ppx filename = + let len = String.length filename in + let processInterface = + isInterface || len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i' + in + let parsingEngine = + match origin with + | "reasonBinary" -> Parser Res_driver_reason_binary.parsingEngine + | "ml" -> Parser Res_driver_ml_parser.parsingEngine + | "res" -> Parser Res_driver.parsingEngine + | "" -> ( + match Filename.extension filename with + | ".ml" | ".mli" -> Parser Res_driver_ml_parser.parsingEngine + | ".re" | ".rei" -> Parser Res_driver_reason_binary.parsingEngine + | _ -> Parser Res_driver.parsingEngine + ) + | origin -> + print_endline ("-parse needs to be either reasonBinary, ml or res. You provided " ^ origin); + exit 1 + in + let printEngine = + match target with + | "binary" -> Res_driver_binary.printEngine + | "ml" -> Res_driver_ml_parser.printEngine + | "ast" -> Res_ast_debugger.printEngine + | "sexp" -> Res_ast_debugger.sexpPrintEngine + | "res" -> Res_driver.printEngine + | target -> + print_endline ("-print needs to be either binary, ml, ast, sexp or res. You provided " ^ target); + exit 1 + in + + let forPrinter = match target with + | "res" | "sexp" -> true + | _ -> false + in + + let Parser backend = parsingEngine in + (* This is the whole purpose of the Color module above *) + Color.setup None; + if processInterface then + let parseResult = backend.parseInterface ~forPrinter ~filename in + if parseResult.invalid then begin + backend.stringOfDiagnostics + ~source:parseResult.source + ~filename:parseResult.filename + parseResult.diagnostics; + if recover then + printEngine.printInterface + ~width ~filename ~comments:parseResult.comments parseResult.parsetree + else exit 1 + end + else + let parsetree = match ppx with + | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_signature parseResult.parsetree + | _ -> parseResult.parsetree + in + printEngine.printInterface + ~width ~filename ~comments:parseResult.comments parsetree + else + let parseResult = backend.parseImplementation ~forPrinter ~filename in + if parseResult.invalid then begin + backend.stringOfDiagnostics + ~source:parseResult.source + ~filename:parseResult.filename + parseResult.diagnostics; + if recover then + printEngine.printImplementation + ~width ~filename ~comments:parseResult.comments parseResult.parsetree + else exit 1 + end + else + let parsetree = match ppx with + | "jsx" -> Reactjs_jsx_ppx_v3.rewrite_implementation parseResult.parsetree + | _ -> parseResult.parsetree + in + printEngine.printImplementation + ~width ~filename ~comments:parseResult.comments parsetree + [@@raises Invalid_argument, Failure, exit] +end + + +(* let [@raises Invalid_argument, Failure, exit] () = + if not !Sys.interactive then begin + ResClflags.parse (); + CliArgProcessor.processFile + ~isInterface:!ResClflags.interface + ~width:!ResClflags.width + ~recover:!ResClflags.recover + ~target:!ResClflags.print + ~origin:!ResClflags.origin + ~ppx:!ResClflags.ppx + !ResClflags.file +end *) diff --git a/analysis/src/vendor/res_outcome_printer/res_comments_table.ml b/analysis/src/vendor/res_outcome_printer/res_comments_table.ml new file mode 100644 index 000000000..c945bd783 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_comments_table.ml @@ -0,0 +1,1918 @@ +module Comment = Res_comment +module Doc = Res_doc + +type t = { + leading: (Location.t, Comment.t list) Hashtbl.t; + inside: (Location.t, Comment.t list) Hashtbl.t; + trailing: (Location.t, Comment.t list) Hashtbl.t; +} + +let make () = { + leading = Hashtbl.create 100; + inside = Hashtbl.create 100; + trailing = Hashtbl.create 100; +} + +let copy tbl = { + leading = Hashtbl.copy tbl.leading; + inside = Hashtbl.copy tbl.inside; + trailing = Hashtbl.copy tbl.trailing; +} + +let empty = make () + +let log t = + let open Location in + let leadingStuff = Hashtbl.fold (fun (k : Location.t) (v : Comment.t list) acc -> + let loc = Doc.concat [ + Doc.lbracket; + Doc.text (string_of_int k.loc_start.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); + Doc.text "-"; + Doc.text (string_of_int k.loc_end.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); + Doc.rbracket; + ] in + let doc = Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + loc; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.comma (List.map (fun c -> Doc.text (Comment.txt c)) v) + ] + ); + Doc.line; + ] + ) in + doc::acc + ) t.leading [] + in + let trailingStuff = Hashtbl.fold (fun (k : Location.t) (v : Comment.t list) acc -> + let loc = Doc.concat [ + Doc.lbracket; + Doc.text (string_of_int k.loc_start.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); + Doc.text "-"; + Doc.text (string_of_int k.loc_end.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); + Doc.rbracket; + ] in + let doc = Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + loc; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun c -> Doc.text (Comment.txt c)) v) + ] + ); + Doc.line; + ] + ) in + doc::acc + ) t.trailing [] + in + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "leading comments:"; + Doc.line; + Doc.indent (Doc.concat leadingStuff); + Doc.line; + Doc.line; + Doc.text "trailing comments:"; + Doc.indent (Doc.concat trailingStuff); + Doc.line; + Doc.line; + ] + ) |> Doc.toString ~width:80 |> print_endline + [@@live] + +let attach tbl loc comments = + match comments with + | [] -> () + | comments -> Hashtbl.replace tbl loc comments + +let partitionByLoc comments loc = + let rec loop (leading, inside, trailing) comments = + let open Location in + match comments with + | comment::rest -> + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment::leading, inside, trailing) rest + else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then + loop (leading, inside, comment::trailing) rest + else + loop (leading, comment::inside, trailing) rest + | [] -> (List.rev leading, List.rev inside, List.rev trailing) + in + loop ([], [], []) comments + +let partitionLeadingTrailing comments loc = + let rec loop (leading, trailing) comments = + let open Location in + match comments with + | comment::rest -> + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment::leading, trailing) rest + else + loop (leading, comment::trailing) rest + | [] -> (List.rev leading, List.rev trailing) + in + loop ([], []) comments + +let partitionByOnSameLine loc comments = + let rec loop (onSameLine, onOtherLine) comments = + let open Location in + match comments with + | [] -> (List.rev onSameLine, List.rev onOtherLine) + | comment::rest -> + let cmtLoc = Comment.loc comment in + if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then + loop (comment::onSameLine, onOtherLine) rest + else + loop (onSameLine, comment::onOtherLine) rest + in + loop ([], []) comments + +let partitionAdjacentTrailing loc1 comments = + let open Location in + let open Lexing in + let rec loop ~prevEndPos afterLoc1 comments = + match comments with + | [] -> (List.rev afterLoc1, []) + | (comment::rest) as comments -> + let cmtPrevEndPos = Comment.prevTokEndPos comment in + if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then + let commentEnd = (Comment.loc comment).loc_end in + loop ~prevEndPos:commentEnd (comment::afterLoc1) rest + else + (List.rev afterLoc1, comments) + in + loop ~prevEndPos:loc1.loc_end [] comments + +let rec collectListPatterns acc pattern = + let open Parsetree in + match pattern.ppat_desc with + | Ppat_construct( + {txt = Longident.Lident "::"}, + Some {ppat_desc=Ppat_tuple (pat::rest::[])} + ) -> + collectListPatterns (pat::acc) rest + | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> + List.rev acc + | _ -> List.rev (pattern::acc) + +let rec collectListExprs acc expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_construct( + {txt = Longident.Lident "::"}, + Some {pexp_desc=Pexp_tuple (expr::rest::[])} + ) -> + collectListExprs (expr::acc) rest + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + List.rev acc + | _ -> List.rev (expr::acc) + +(* TODO: use ParsetreeViewer *) +let arrowType ct = + let open Parsetree in + let rec process attrsBefore acc typ = match typ with + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = []} -> + let arg = ([], lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = [({txt ="bs"}, _) ] as attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) + | {ptyp_desc = Ptyp_arrow ((Labelled _ | Optional _) as lbl, typ1, typ2); ptyp_attributes = attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | typ -> + (attrsBefore, List.rev acc, typ) + in + begin match ct with + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> + process attrs [] {typ with ptyp_attributes = []} + | typ -> process [] [] typ + end + +(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) +let modExprApply modExpr = + let rec loop acc modExpr = match modExpr with + | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> + loop (arg::acc) next + | _ -> (modExpr::acc) + in + loop [] modExpr + +(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) +let modExprFunctor modExpr = + let rec loop acc modExpr = match modExpr with + | {Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} -> + let param = (attrs, lbl, modType) in + loop (param::acc) returnModExpr + | returnModExpr -> + (List.rev acc, returnModExpr) + in + loop [] modExpr + +let functorType modtype = + let rec process acc modtype = match modtype with + | {Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs} -> + let arg = (attrs, lbl, argType) in + process (arg::acc) returnType + | modType -> + (List.rev acc, modType) + in + process [] modtype + +let funExpr expr = + let open Parsetree in + (* Turns (type t, type u, type z) into "type t u z" *) + let rec collectNewTypes acc returnExpr = + match returnExpr with + | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} -> + collectNewTypes (stringLoc::acc) returnExpr + | returnExpr -> + let loc = match (acc, List.rev acc) with + | (_startLoc::_, endLoc::_) -> { endLoc.loc with loc_end = endLoc.loc.loc_end } + | _ -> Location.none + in + let txt = List.fold_right (fun curr acc -> acc ^ " " ^ curr.Location.txt) acc "type" in + (Location.mkloc txt loc, returnExpr) + in + (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, + * otherwise this function would need to return a variant: + * | NormalParamater(...) + * | NewType(...) + * This complicates printing with an extra variant/boxing/allocation for a code-path + * that is not often used. Lets just keep it simple for now *) + let rec collect attrsBefore acc expr = match expr with + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []} -> + let parameter = ([], lbl, defaultExpr, pattern) in + collect attrsBefore (parameter::acc) returnExpr + | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> + let (var, returnExpr) = collectNewTypes [stringLoc] rest in + let parameter = ( + attrs, + Asttypes.Nolabel, + None, + Ast_helper.Pat.var ~loc:stringLoc.loc var + ) in + collect attrsBefore (parameter::acc) returnExpr + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = [({txt = "bs"}, _)] as attrs} -> + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter::acc) returnExpr + | { + pexp_desc = Pexp_fun ((Labelled _ | Optional _) as lbl, defaultExpr, pattern, returnExpr); + pexp_attributes = attrs + } -> + let parameter = (attrs, lbl, defaultExpr, pattern) in + collect attrsBefore (parameter::acc) returnExpr + | expr -> + (attrsBefore, List.rev acc, expr) + in + begin match expr with + | {pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs} as expr -> + collect attrs [] {expr with pexp_attributes = []} + | expr -> collect [] [] expr + end + +let rec isBlockExpr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_let _ + | Pexp_open _ + | Pexp_sequence _ -> true + | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true + | Pexp_constraint (expr, _) when isBlockExpr expr -> true + | Pexp_field (expr, _) when isBlockExpr expr -> true + | Pexp_setfield (expr, _, _) when isBlockExpr expr -> true + | _ -> false + +let isIfThenElseExpr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_ifthenelse _ -> true + | _ -> false + +let rec walkStructure s t comments = + match s with + | _ when comments = [] -> () + | [] -> attach t.inside Location.none comments + | s -> + walkList + ~getLoc:(fun n -> n.Parsetree.pstr_loc) + ~walkNode:walkStructureItem + s + t + comments + + and walkStructureItem si t comments = + match si.Parsetree.pstr_desc with + | _ when comments = [] -> () + | Pstr_primitive valueDescription -> + walkValueDescription valueDescription t comments + | Pstr_open openDescription -> + walkOpenDescription openDescription t comments + | Pstr_value (_, valueBindings) -> + walkValueBindings valueBindings t comments + | Pstr_type (_, typeDeclarations) -> + walkTypeDeclarations typeDeclarations t comments + | Pstr_eval (expr, _) -> + walkExpr expr t comments + | Pstr_module moduleBinding -> + walkModuleBinding moduleBinding t comments + | Pstr_recmodule moduleBindings -> + walkList + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~walkNode:walkModuleBinding + moduleBindings + t + comments + | Pstr_modtype modTypDecl -> + walkModuleTypeDeclaration modTypDecl t comments + | Pstr_attribute attribute -> + walkAttribute attribute t comments + | Pstr_extension (extension, _) -> + walkExtension extension t comments + | Pstr_include includeDeclaration -> + walkIncludeDeclaration includeDeclaration t comments + | Pstr_exception extensionConstructor -> + walkExtConstr extensionConstructor t comments + | Pstr_typext typeExtension -> + walkTypeExtension typeExtension t comments + | Pstr_class_type _ | Pstr_class _ -> () + + and walkValueDescription vd t comments = + let (leading, trailing) = + partitionLeadingTrailing comments vd.pval_name.loc in + attach t.leading vd.pval_name.loc leading; + let (afterName, rest) = + partitionAdjacentTrailing vd.pval_name.loc trailing in + attach t.trailing vd.pval_name.loc afterName; + let (before, inside, after) = + partitionByLoc rest vd.pval_type.ptyp_loc + in + attach t.leading vd.pval_type.ptyp_loc before; + walkTypExpr vd.pval_type t inside; + attach t.trailing vd.pval_type.ptyp_loc after + + and walkTypeExtension te t comments = + let (leading, trailing) = + partitionLeadingTrailing comments te.ptyext_path.loc in + attach t.leading te.ptyext_path.loc leading; + let (afterPath, rest) = + partitionAdjacentTrailing te.ptyext_path.loc trailing in + attach t.trailing te.ptyext_path.loc afterPath; + + (* type params *) + let rest = match te.ptyext_params with + | [] -> rest + | typeParams -> + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam + ~newlineDelimited:false + typeParams + t + rest + in + walkList + ~getLoc:(fun n -> n.Parsetree.pext_loc) + ~walkNode:walkExtConstr + te.ptyext_constructors + t + rest + + and walkIncludeDeclaration inclDecl t comments = + let (before, inside, after) = + partitionByLoc comments inclDecl.pincl_mod.pmod_loc in + attach t.leading inclDecl.pincl_mod.pmod_loc before; + walkModExpr inclDecl.pincl_mod t inside; + attach t.trailing inclDecl.pincl_mod.pmod_loc after + + and walkModuleTypeDeclaration mtd t comments = + let (leading, trailing) = + partitionLeadingTrailing comments mtd.pmtd_name.loc in + attach t.leading mtd.pmtd_name.loc leading; + begin match mtd.pmtd_type with + | None -> + attach t.trailing mtd.pmtd_name.loc trailing + | Some modType -> + let (afterName, rest) = partitionAdjacentTrailing mtd.pmtd_name.loc trailing in + attach t.trailing mtd.pmtd_name.loc afterName; + let (before, inside, after) = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after + end + + and walkModuleBinding mb t comments = + let (leading, trailing) = partitionLeadingTrailing comments mb.pmb_name.loc in + attach t.leading mb.pmb_name.loc leading; + let (afterName, rest) = partitionAdjacentTrailing mb.pmb_name.loc trailing in + attach t.trailing mb.pmb_name.loc afterName; + let (leading, inside, trailing) = partitionByLoc rest mb.pmb_expr.pmod_loc in + begin match mb.pmb_expr.pmod_desc with + | Pmod_constraint _ -> + walkModExpr mb.pmb_expr t (List.concat [leading; inside]); + | _ -> + attach t.leading mb.pmb_expr.pmod_loc leading; + walkModExpr mb.pmb_expr t inside; + end; + attach t.trailing mb.pmb_expr.pmod_loc trailing + + and walkSignature signature t comments = + match signature with + | _ when comments = [] -> () + | [] -> attach t.inside Location.none comments + | _s -> + walkList + ~getLoc:(fun n -> n.Parsetree.psig_loc) + ~walkNode:walkSignatureItem + signature + t + comments + + and walkSignatureItem si t comments = + match si.psig_desc with + | _ when comments = [] -> () + | Psig_value valueDescription -> + walkValueDescription valueDescription t comments + | Psig_type (_, typeDeclarations) -> + walkTypeDeclarations typeDeclarations t comments + | Psig_typext typeExtension -> + walkTypeExtension typeExtension t comments + | Psig_exception extensionConstructor -> + walkExtConstr extensionConstructor t comments + | Psig_module moduleDeclaration -> + walkModuleDeclaration moduleDeclaration t comments + | Psig_recmodule moduleDeclarations -> + walkList + ~getLoc:(fun n -> n.Parsetree.pmd_loc) + ~walkNode:walkModuleDeclaration + moduleDeclarations + t + comments + | Psig_modtype moduleTypeDeclaration -> + walkModuleTypeDeclaration moduleTypeDeclaration t comments + | Psig_open openDescription -> + walkOpenDescription openDescription t comments + | Psig_include includeDescription -> + walkIncludeDescription includeDescription t comments + | Psig_attribute attribute -> + walkAttribute attribute t comments + | Psig_extension (extension, _) -> + walkExtension extension t comments + | Psig_class _ | Psig_class_type _ -> () + + and walkIncludeDescription id t comments = + let (before, inside, after) = + partitionByLoc comments id.pincl_mod.pmty_loc in + attach t.leading id.pincl_mod.pmty_loc before; + walkModType id.pincl_mod t inside; + attach t.trailing id.pincl_mod.pmty_loc after + + and walkModuleDeclaration md t comments = + let (leading, trailing) = partitionLeadingTrailing comments md.pmd_name.loc in + attach t.leading md.pmd_name.loc leading; + let (afterName, rest) = partitionAdjacentTrailing md.pmd_name.loc trailing in + attach t.trailing md.pmd_name.loc afterName; + let (leading, inside, trailing) = partitionByLoc rest md.pmd_type.pmty_loc in + attach t.leading md.pmd_type.pmty_loc leading; + walkModType md.pmd_type t inside; + attach t.trailing md.pmd_type.pmty_loc trailing + + and walkList: + 'node. + ?prevLoc:Location.t -> + getLoc:('node -> Location.t) -> + walkNode:('node -> t -> Comment.t list -> unit) -> + 'node list -> t -> Comment.t list -> unit + = fun ?prevLoc ~getLoc ~walkNode l t comments -> + let open Location in + match l with + | _ when comments = [] -> () + | [] -> + begin match prevLoc with + | Some loc -> + attach t.trailing loc comments + | None -> () + end + | node::rest -> + let currLoc = getLoc node in + let (leading, inside, trailing) = partitionByLoc comments currLoc in + begin match prevLoc with + | None -> (* first node, all leading comments attach here *) + attach t.leading currLoc leading + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then + let (afterPrev, beforeCurr) = partitionAdjacentTrailing prevLoc leading in + let () = attach t.trailing prevLoc afterPrev in + attach t.leading currLoc beforeCurr + else + let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine prevLoc leading in + let () = attach t.trailing prevLoc onSameLineAsPrev in + let (leading, _inside, _trailing) = partitionByLoc afterPrev currLoc in + attach t.leading currLoc leading + end; + walkNode node t inside; + walkList ~prevLoc:currLoc ~getLoc ~walkNode rest t trailing + + (* The parsetree doesn't always contain location info about the opening or + * closing token of a "list-of-things". This routine visits the whole list, + * but returns any remaining comments that likely fall after the whole list. *) + and visitListButContinueWithRemainingComments: + 'node. + ?prevLoc:Location.t -> + newlineDelimited:bool -> + getLoc:('node -> Location.t) -> + walkNode:('node -> t -> Comment.t list -> unit) -> + 'node list -> t -> Comment.t list -> Comment.t list + = fun ?prevLoc ~newlineDelimited ~getLoc ~walkNode l t comments -> + let open Location in + match l with + | _ when comments = [] -> [] + | [] -> + begin match prevLoc with + | Some loc -> + let (afterPrev, rest) = + if newlineDelimited then + partitionByOnSameLine loc comments + else + partitionAdjacentTrailing loc comments + in + attach t.trailing loc afterPrev; + rest + | None -> comments + end + | node::rest -> + let currLoc = getLoc node in + let (leading, inside, trailing) = partitionByLoc comments currLoc in + let () = match prevLoc with + | None -> (* first node, all leading comments attach here *) + attach t.leading currLoc leading; + () + | Some prevLoc -> + (* Same line *) + if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then + let (afterPrev, beforeCurr) = partitionAdjacentTrailing prevLoc leading in + let () = attach t.trailing prevLoc afterPrev in + let () = attach t.leading currLoc beforeCurr in + () + else + let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine prevLoc leading in + let () = attach t.trailing prevLoc onSameLineAsPrev in + let (leading, _inside, _trailing) = partitionByLoc afterPrev currLoc in + let () = attach t.leading currLoc leading in + () + in + walkNode node t inside; + visitListButContinueWithRemainingComments + ~prevLoc:currLoc ~getLoc ~walkNode ~newlineDelimited + rest t trailing + + and walkValueBindings vbs t comments = + walkList + ~getLoc:(fun n -> n.Parsetree.pvb_loc) + ~walkNode:walkValueBinding + vbs + t + comments + + and walkOpenDescription openDescription t comments = + let loc = openDescription.popen_lid.loc in + let (leading, trailing) = partitionLeadingTrailing comments loc in + attach t.leading loc leading; + attach t.trailing loc trailing; + + and walkTypeDeclarations typeDeclarations t comments = + walkList + ~getLoc:(fun n -> n.Parsetree.ptype_loc) + ~walkNode:walkTypeDeclaration + typeDeclarations + t + comments + + and walkTypeParam (typexpr, _variance) t comments = + walkTypExpr typexpr t comments + + and walkTypeDeclaration td t comments = + let (beforeName, rest) = + partitionLeadingTrailing comments td.ptype_name.loc in + attach t.leading td.ptype_name.loc beforeName; + + let (afterName, rest) = + partitionAdjacentTrailing td.ptype_name.loc rest in + attach t.trailing td.ptype_name.loc afterName; + + (* type params *) + let rest = match td.ptype_params with + | [] -> rest + | typeParams -> + visitListButContinueWithRemainingComments + ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walkNode:walkTypeParam + ~newlineDelimited:false + typeParams + t + rest + in + + (* manifest: = typexpr *) + let rest = match td.ptype_manifest with + | Some typexpr -> + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + let (afterTyp, rest) = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + + let rest = match td.ptype_kind with + | Ptype_abstract | Ptype_open -> rest + | Ptype_record labelDeclarations -> + let () = walkList + ~getLoc:(fun ld -> ld.Parsetree.pld_loc) + ~walkNode:walkLabelDeclaration + labelDeclarations + t + rest + in + [] + | Ptype_variant constructorDeclarations -> + walkConstructorDeclarations constructorDeclarations t rest + in + attach t.trailing td.ptype_loc rest + + and walkLabelDeclarations lds t comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun ld -> ld.Parsetree.pld_loc) + ~walkNode:walkLabelDeclaration + ~newlineDelimited:false + lds + t + comments + + and walkLabelDeclaration ld t comments = + let (beforeName, rest) = + partitionLeadingTrailing comments ld.pld_name.loc in + attach t.leading ld.pld_name.loc beforeName; + let (afterName, rest) = partitionAdjacentTrailing ld.pld_name.loc rest in + attach t.trailing ld.pld_name.loc afterName; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest ld.pld_type.ptyp_loc in + attach t.leading ld.pld_type.ptyp_loc beforeTyp; + walkTypExpr ld.pld_type t insideTyp; + attach t.trailing ld.pld_type.ptyp_loc afterTyp + + and walkConstructorDeclarations cds t comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) + ~walkNode:walkConstructorDeclaration + ~newlineDelimited:false + cds + t + comments + + and walkConstructorDeclaration cd t comments = + let (beforeName, rest) = + partitionLeadingTrailing comments cd.pcd_name.loc in + attach t.leading cd.pcd_name.loc beforeName; + let (afterName, rest) = + partitionAdjacentTrailing cd.pcd_name.loc rest in + attach t.trailing cd.pcd_name.loc afterName; + let rest = walkConstructorArguments cd.pcd_args t rest in + + let rest = match cd.pcd_res with + | Some typexpr -> + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + let (afterTyp, rest) = + partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + attach t.trailing cd.pcd_loc rest + + and walkConstructorArguments args t comments = + match args with + | Pcstr_tuple typexprs -> + visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkTypExpr + ~newlineDelimited:false + typexprs + t + comments + | Pcstr_record labelDeclarations -> + walkLabelDeclarations labelDeclarations t comments + + and walkValueBinding vb t comments = + let open Location in + + let vb = + let open Parsetree in + match (vb.pvb_pat, vb.pvb_expr) with + | {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, + {pexp_desc = Pexp_constraint (expr, _typ)} -> + {vb with + pvb_pat = Ast_helper.Pat.constraint_ + ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} pat t; + pvb_expr = expr; + } + | {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_::_, t)})}, + {pexp_desc = Pexp_fun _} -> + {vb with + pvb_pat = {vb.pvb_pat with + ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}}} + + | ({ppat_desc = Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_::_, t)} as typ))} as constrainedPattern), + {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} -> + (* + * The location of the Ptyp_poly on the pattern is the whole thing. + * let x: + * type t. (int, int) => int = + * (a, b) => { + * // comment + * a + b + * } + *) + {vb with + pvb_pat = { + constrainedPattern with + ppat_desc = Ppat_constraint (pat, typ); + ppat_loc = {constrainedPattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; + }; + pvb_expr = expr + } + | _ -> vb + in + let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in + let exprLoc = vb.Parsetree.pvb_expr.pexp_loc in + let expr = vb.pvb_expr in + + let (leading, inside, trailing) = + partitionByLoc comments patternLoc in + + (* everything before start of pattern can only be leading on the pattern: + * let |* before *| a = 1 *) + attach t.leading patternLoc leading; + walkPattern vb.Parsetree.pvb_pat t inside; + let (afterPat, surroundingExpr) = + partitionAdjacentTrailing patternLoc trailing + in + attach t.trailing patternLoc afterPat; + let (beforeExpr, insideExpr, afterExpr) = + partitionByLoc surroundingExpr exprLoc in + if isBlockExpr expr then ( + walkExpr expr t (List.concat [beforeExpr; insideExpr; afterExpr]) + ) else ( + attach t.leading exprLoc beforeExpr; + walkExpr expr t insideExpr; + attach t.trailing exprLoc afterExpr + ) + + and walkExpr expr t comments = + let open Location in + match expr.Parsetree.pexp_desc with + | _ when comments = [] -> () + | Pexp_constant _ -> + let (leading, trailing) = + partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + attach t.trailing expr.pexp_loc trailing; + | Pexp_ident longident -> + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing; + | Pexp_let ( + _recFlag, + valueBindings, + {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} + ) -> + walkValueBindings valueBindings t comments + | Pexp_let (_recFlag, valueBindings, expr2) -> + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun n -> + if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then + n.pvb_expr.pexp_loc + else + n.Parsetree.pvb_loc + ) + ~walkNode:walkValueBinding + ~newlineDelimited:true + valueBindings + t + comments + in + if isBlockExpr expr2 then ( + walkExpr expr2 t comments; + ) else ( + let (leading, inside, trailing) = partitionByLoc comments expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_sequence (expr1, expr2) -> + let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in + let comments = if isBlockExpr expr1 then ( + let (afterExpr, comments) = partitionByOnSameLine expr1.pexp_loc trailing in + walkExpr expr1 t (List.concat [leading; inside; afterExpr]); + comments + ) else ( + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + let (afterExpr, comments) = partitionByOnSameLine expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; + comments + ) in + if isBlockExpr expr2 then ( + walkExpr expr2 t comments + ) else ( + let (leading, inside, trailing) = partitionByLoc comments expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_open (_override, longident, expr2) -> + let (leading, comments) = + partitionLeadingTrailing comments expr.pexp_loc in + attach + t.leading + {expr.pexp_loc with loc_end = longident.loc.loc_end} + leading; + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + let (afterLongident, rest) = + partitionByOnSameLine longident.loc trailing in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then ( + walkExpr expr2 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_extension ( + {txt = "bs.obj" | "obj"}, + PStr [{ + pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, []) + }] + ) -> + walkList + ~getLoc:(fun ( + (longident, expr): (Longident.t Asttypes.loc * Parsetree.expression) + ) -> { + longident.loc with loc_end = expr.pexp_loc.loc_end + }) + ~walkNode:walkExprRecordRow + rows + t + comments + | Pexp_extension extension -> + walkExtension extension t comments + | Pexp_letexception (extensionConstructor, expr2) -> + let (leading, comments) = + partitionLeadingTrailing comments expr.pexp_loc in + attach + t.leading + {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} + leading; + let (leading, inside, trailing) = + partitionByLoc comments extensionConstructor.pext_loc in + attach t.leading extensionConstructor.pext_loc leading; + walkExtConstr extensionConstructor t inside; + let (afterExtConstr, rest) = + partitionByOnSameLine extensionConstructor.pext_loc trailing in + attach t.trailing extensionConstructor.pext_loc afterExtConstr; + if isBlockExpr expr2 then ( + walkExpr expr2 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_letmodule (stringLoc, modExpr, expr2) -> + let (leading, comments) = + partitionLeadingTrailing comments expr.pexp_loc in + attach t.leading {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} leading; + let (leading, trailing) = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + let (afterString, rest) = + partitionAdjacentTrailing stringLoc.loc trailing in + attach t.trailing stringLoc.loc afterString; + let (beforeModExpr, insideModExpr, afterModExpr) = + partitionByLoc rest modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc beforeModExpr; + walkModExpr modExpr t insideModExpr; + let (afterModExpr, rest) = + partitionByOnSameLine modExpr.pmod_loc afterModExpr in + attach t.trailing modExpr.pmod_loc afterModExpr; + if isBlockExpr expr2 then ( + walkExpr expr2 t rest; + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_assert expr + | Pexp_lazy expr -> + if isBlockExpr expr then ( + walkExpr expr t comments + ) else ( + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + | Pexp_coerce (expr, optTypexpr, typexpr) -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let rest = match optTypexpr with + | Some typexpr -> + let (leading, inside, trailing) = partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkTypExpr typexpr t inside; + let (afterTyp, rest) = + partitionAdjacentTrailing typexpr.ptyp_loc trailing in + attach t.trailing typexpr.ptyp_loc afterTyp; + rest + | None -> rest + in + let (leading, inside, trailing) = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkTypExpr typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing + | Pexp_constraint (expr, typexpr) -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let (leading, inside, trailing) = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walkTypExpr typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing + | Pexp_tuple [] + | Pexp_array [] + | Pexp_construct({txt = Longident.Lident "[]"}, _) -> + attach t.inside expr.pexp_loc comments + | Pexp_construct({txt = Longident.Lident "::"}, _) -> + walkList + ~getLoc:(fun n -> n.Parsetree.pexp_loc) + ~walkNode:walkExpr + (collectListExprs [] expr) + t + comments + | Pexp_construct (longident, args) -> + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + begin match args with + | Some expr -> + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc trailing in + attach t.trailing longident.loc afterLongident; + walkExpr expr t rest + | None -> + attach t.trailing longident.loc trailing + end + | Pexp_variant (_label, None) -> + () + | Pexp_variant (_label, Some expr) -> + walkExpr expr t comments + | Pexp_array exprs | Pexp_tuple exprs -> + walkList + ~getLoc:(fun n -> n.Parsetree.pexp_loc) + ~walkNode:walkExpr + exprs + t + comments + | Pexp_record (rows, spreadExpr) -> + let comments = match spreadExpr with + | None -> comments + | Some expr -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + rest + in + walkList + ~getLoc:(fun ( + (longident, expr): (Longident.t Asttypes.loc * Parsetree.expression) + ) -> { + longident.loc with loc_end = expr.pexp_loc.loc_end + }) + ~walkNode:walkExprRecordRow + rows + t + comments + | Pexp_field (expr, longident) -> + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + let trailing = if isBlockExpr expr then ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc trailing in + walkExpr expr t (List.concat [leading; inside; afterExpr]); + rest + ) else ( + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + trailing + ) in + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc afterExpr; + let (leading, trailing) = partitionLeadingTrailing rest longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pexp_setfield (expr1, longident, expr2) -> + let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in + let rest = if isBlockExpr expr1 then ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr1.pexp_loc trailing in + walkExpr expr1 t (List.concat [leading; inside; afterExpr]); + rest + ) else ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + attach t.trailing expr1.pexp_loc afterExpr; + rest + ) in + let (beforeLongident, afterLongident) = partitionLeadingTrailing rest longident.loc in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + if isBlockExpr expr2 then + walkExpr expr2 t rest + else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> + let (leading, inside, trailing) = partitionByLoc comments ifExpr.pexp_loc in + let comments = if isBlockExpr ifExpr then ( + let (afterExpr, comments) = partitionAdjacentTrailing ifExpr.pexp_loc trailing in + walkExpr ifExpr t (List.concat [leading; inside; afterExpr]); + comments + ) else ( + attach t.leading ifExpr.pexp_loc leading; + walkExpr ifExpr t inside; + let (afterExpr, comments) = partitionAdjacentTrailing ifExpr.pexp_loc trailing in + attach t.trailing ifExpr.pexp_loc afterExpr; + comments + ) in + let (leading, inside, trailing) = partitionByLoc comments thenExpr.pexp_loc in + let comments = if isBlockExpr thenExpr then ( + let (afterExpr, trailing) = partitionAdjacentTrailing thenExpr.pexp_loc trailing in + walkExpr thenExpr t (List.concat [leading; inside; afterExpr]); + trailing + ) else ( + attach t.leading thenExpr.pexp_loc leading; + walkExpr thenExpr t inside; + let (afterExpr, comments) = partitionAdjacentTrailing thenExpr.pexp_loc trailing in + attach t.trailing thenExpr.pexp_loc afterExpr; + comments + ) in + begin match elseExpr with + | None -> () + | Some expr -> + if isBlockExpr expr || isIfThenElseExpr expr then + walkExpr expr t comments + else ( + let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + end + | Pexp_while (expr1, expr2) -> + let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in + let rest = if isBlockExpr expr1 then + let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in + walkExpr expr1 t (List.concat [leading; inside; afterExpr]); + rest + else ( + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; + rest + ) in + if isBlockExpr expr2 then ( + walkExpr expr2 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + ) + | Pexp_for (pat, expr1, expr2, _, expr3) -> + let (leading, inside, trailing) = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let (afterPat, rest) = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.trailing pat.ppat_loc afterPat; + let (leading, inside, trailing) = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc leading; + walkExpr expr1 t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in + attach t.trailing expr1.pexp_loc afterExpr; + let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walkExpr expr2 t inside; + let (afterExpr, rest) = partitionAdjacentTrailing expr2.pexp_loc trailing in + attach t.trailing expr2.pexp_loc afterExpr; + if isBlockExpr expr3 then ( + walkExpr expr3 t rest + ) else ( + let (leading, inside, trailing) = partitionByLoc rest expr3.pexp_loc in + attach t.leading expr3.pexp_loc leading; + walkExpr expr3 t inside; + attach t.trailing expr3.pexp_loc trailing + ) + | Pexp_pack modExpr -> + let (before, inside, after) = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | Pexp_match (expr1, [case; elseBranch]) + when Res_parsetree_viewer.hasIfLetAttribute expr.pexp_attributes -> + let (before, inside, after) = partitionByLoc comments case.pc_lhs.ppat_loc in + attach t.leading case.pc_lhs.ppat_loc before; + walkPattern case.pc_lhs t inside; + let (afterPat, rest) = + partitionAdjacentTrailing case.pc_lhs.ppat_loc after in + attach t.trailing case.pc_lhs.ppat_loc afterPat; + let (before, inside, after) = partitionByLoc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc before; + walkExpr expr1 t inside; + let (afterExpr, rest) = + partitionAdjacentTrailing expr1.pexp_loc after in + attach t.trailing expr1.pexp_loc afterExpr; + let (before, inside, after) = partitionByLoc rest case.pc_rhs.pexp_loc in + let after = if isBlockExpr case.pc_rhs then ( + let (afterExpr, rest) = + partitionAdjacentTrailing case.pc_rhs.pexp_loc after in + walkExpr case.pc_rhs t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading case.pc_rhs.pexp_loc before; + walkExpr case.pc_rhs t inside; + after + ) in + let (afterExpr, rest) = partitionAdjacentTrailing case.pc_rhs.pexp_loc after in + attach t.trailing case.pc_rhs.pexp_loc afterExpr; + let (before, inside, after) = partitionByLoc rest elseBranch.pc_rhs.pexp_loc in + let after = if isBlockExpr elseBranch.pc_rhs then ( + let (afterExpr, rest) = + partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after in + walkExpr elseBranch.pc_rhs t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading elseBranch.pc_rhs.pexp_loc before; + walkExpr elseBranch.pc_rhs t inside; + after + ) in + attach t.trailing elseBranch.pc_rhs.pexp_loc after + + | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> + let (before, inside, after) = partitionByLoc comments expr.pexp_loc in + let after = if isBlockExpr expr then ( + let (afterExpr, rest) = + partitionAdjacentTrailing expr.pexp_loc after in + walkExpr expr t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + after + ) in + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc after in + attach t.trailing expr.pexp_loc afterExpr; + walkList + ~getLoc:(fun n -> {n.Parsetree.pc_lhs.ppat_loc with + loc_end = n.pc_rhs.pexp_loc.loc_end}) + ~walkNode:walkCase + cases + t + rest + (* unary expression: todo use parsetreeviewer *) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident + ("~+" | "~+." | "~-" | "~-." | "not" | "!") + }}, + [Nolabel, argExpr] + ) -> + let (before, inside, after) = partitionByLoc comments argExpr.pexp_loc in + attach t.leading argExpr.pexp_loc before; + walkExpr argExpr t inside; + attach t.trailing argExpr.pexp_loc after + (* binary expression *) + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident + (":=" | "||" | "&&" | "=" | "==" | "<" | ">" + | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." + | "-" | "-." | "++" | "^" | "*" | "*." | "/" + | "/." | "**" | "|." | "<>") }}, + [(Nolabel, operand1); (Nolabel, operand2)] + ) -> + let (before, inside, after) = partitionByLoc comments operand1.pexp_loc in + attach t.leading operand1.pexp_loc before; + walkExpr operand1 t inside; + let (afterOperand1, rest) = + partitionAdjacentTrailing operand1.pexp_loc after in + attach t.trailing operand1.pexp_loc afterOperand1; + let (before, inside, after) = partitionByLoc rest operand2.pexp_loc in + attach t.leading operand2.pexp_loc before; + walkExpr operand2 t inside; (* (List.concat [inside; after]); *) + attach t.trailing operand2.pexp_loc after; + | Pexp_apply (callExpr, arguments) -> + let (before, inside, after) = partitionByLoc comments callExpr.pexp_loc in + let after = if isBlockExpr callExpr then ( + let (afterExpr, rest) = + partitionAdjacentTrailing callExpr.pexp_loc after in + walkExpr callExpr t (List.concat [before; inside; afterExpr]); + rest + ) else ( + attach t.leading callExpr.pexp_loc before; + walkExpr callExpr t inside; + after + ) in + let (afterExpr, rest) = partitionAdjacentTrailing callExpr.pexp_loc after in + attach t.trailing callExpr.pexp_loc afterExpr; + walkList + ~getLoc:(fun (_argLabel, expr) -> + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + {loc with loc_end = expr.pexp_loc.loc_end} + | _ -> + expr.pexp_loc + ) + ~walkNode:walkExprArgument + arguments + t + rest + | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> + let (_, parameters, returnExpr) = funExpr expr in + let comments = visitListButContinueWithRemainingComments + ~newlineDelimited:false + ~walkNode:walkExprPararameter + ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> + let open Parsetree in + let startPos = match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + loc.loc_start + | _ -> + pattern.ppat_loc.loc_start + in + match exprOpt with + | None -> {pattern.ppat_loc with loc_start = startPos} + | Some expr -> { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end + } + ) + parameters + t + comments + in + begin match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) + when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum + -> + let (leading, inside, trailing) = partitionByLoc comments typ.ptyp_loc in + attach t.leading typ.ptyp_loc leading; + walkTypExpr typ t inside; + let (afterTyp, comments) = + partitionAdjacentTrailing typ.ptyp_loc trailing in + attach t.trailing typ.ptyp_loc afterTyp; + if isBlockExpr expr then + walkExpr expr t comments + else ( + let (leading, inside, trailing) = + partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + | _ -> + if isBlockExpr returnExpr then + walkExpr returnExpr t comments + else ( + let (leading, inside, trailing) = + partitionByLoc comments returnExpr.pexp_loc in + attach t.leading returnExpr.pexp_loc leading; + walkExpr returnExpr t inside; + attach t.trailing returnExpr.pexp_loc trailing + ) + end + | _ -> () + +and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = + let (leading, inside, trailing) = partitionByLoc comments pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + begin match exprOpt with + | Some expr -> + let (_afterPat, rest) = + partitionAdjacentTrailing pattern.ppat_loc trailing in + attach t.trailing pattern.ppat_loc trailing; + if isBlockExpr expr then + walkExpr expr t rest + else ( + let (leading, inside, trailing) = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + ) + | None -> + attach t.trailing pattern.ppat_loc trailing + end + +and walkExprArgument (_argLabel, expr) t comments = + match expr.Parsetree.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + let (leading, trailing) = partitionLeadingTrailing comments loc in + attach t.leading loc leading; + let (afterLabel, rest) = partitionAdjacentTrailing loc trailing in + attach t.trailing loc afterLabel; + let (before, inside, after) = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc after + | _ -> + let (before, inside, after) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc after + + and walkCase case t comments = + let (before, inside, after) = partitionByLoc comments case.pc_lhs.ppat_loc in + (* cases don't have a location on their own, leading comments should go + * after the bar on the pattern *) + walkPattern case.pc_lhs t (List.concat [before; inside]); + let (afterPat, rest) = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in + attach t.trailing case.pc_lhs.ppat_loc afterPat; + let comments = match case.pc_guard with + | Some expr -> + let (before, inside, after) = partitionByLoc rest expr.pexp_loc in + let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc after in + if isBlockExpr expr then ( + walkExpr expr t (List.concat [before; inside; afterExpr]) + ) else ( + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc afterExpr; + ); + rest + | None -> rest + in + if isBlockExpr case.pc_rhs then ( + walkExpr case.pc_rhs t comments + ) else ( + let (before, inside, after) = partitionByLoc comments case.pc_rhs.pexp_loc in + attach t.leading case.pc_rhs.pexp_loc before; + walkExpr case.pc_rhs t inside; + attach t.trailing case.pc_rhs.pexp_loc after + ) + + and walkExprRecordRow (longident, expr) t comments = + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + let (leading, inside, trailing) = partitionByLoc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc trailing + + and walkExtConstr extConstr t comments = + let (leading, trailing) = + partitionLeadingTrailing comments extConstr.pext_name.loc in + attach t.leading extConstr.pext_name.loc leading; + let (afterName, rest) = + partitionAdjacentTrailing extConstr.pext_name.loc trailing in + attach t.trailing extConstr.pext_name.loc afterName; + walkExtensionConstructorKind extConstr.pext_kind t rest + + and walkExtensionConstructorKind kind t comments = + match kind with + | Pext_rebind longident -> + let (leading, trailing) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pext_decl (constructorArguments, maybeTypExpr) -> + let rest = walkConstructorArguments constructorArguments t comments in + begin match maybeTypExpr with + | None -> () + | Some typexpr -> + let (before, inside, after) = partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc before; + walkTypExpr typexpr t inside; + attach t.trailing typexpr.ptyp_loc after + end + + and walkModExpr modExpr t comments = + match modExpr.pmod_desc with + | Pmod_ident longident -> + let (before, after) = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc before; + attach t.trailing longident.loc after + | Pmod_structure [] -> + attach t.inside modExpr.pmod_loc comments + | Pmod_structure structure -> + walkStructure structure t comments + | Pmod_extension extension -> + walkExtension extension t comments + | Pmod_unpack expr -> + let (before, inside, after) = partitionByLoc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walkExpr expr t inside; + attach t.trailing expr.pexp_loc after + | Pmod_constraint (modexpr, modtype) -> + if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( + let (before, inside, after) = partitionByLoc comments modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModExpr modexpr t inside; + let (after, rest) = partitionAdjacentTrailing modexpr.pmod_loc after in + attach t.trailing modexpr.pmod_loc after; + let (before, inside, after) = partitionByLoc rest modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + attach t.trailing modtype.pmty_loc after + ) else ( + let (before, inside, after) = partitionByLoc comments modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walkModType modtype t inside; + let (after, rest) = partitionAdjacentTrailing modtype.pmty_loc after in + attach t.trailing modtype.pmty_loc after; + let (before, inside, after) = partitionByLoc rest modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walkModExpr modexpr t inside; + attach t.trailing modexpr.pmod_loc after; + ) + | Pmod_apply (_callModExpr, _argModExpr) -> + let modExprs = modExprApply modExpr in + walkList + ~getLoc:(fun n -> n.Parsetree.pmod_loc) + ~walkNode:walkModExpr + modExprs + t + comments + | Pmod_functor _ -> + let (parameters, returnModExpr) = modExprFunctor modExpr in + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun + (_, lbl, modTypeOption) -> match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + ) + ~walkNode:walkModExprParameter + ~newlineDelimited:false + parameters + t + comments + in + begin match returnModExpr.pmod_desc with + | Pmod_constraint (modExpr, modType) + when modType.pmty_loc.loc_end.pos_cnum <= modExpr.pmod_loc.loc_start.pos_cnum -> + let (before, inside, after) = partitionByLoc comments modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + let (after, rest) = partitionAdjacentTrailing modType.pmty_loc after in + attach t.trailing modType.pmty_loc after; + let (before, inside, after) = partitionByLoc rest modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after + | _ -> + let (before, inside, after) = partitionByLoc comments returnModExpr.pmod_loc in + attach t.leading returnModExpr.pmod_loc before; + walkModExpr returnModExpr t inside; + attach t.trailing returnModExpr.pmod_loc after + end + + and walkModExprParameter parameter t comments = + let (_attrs, lbl, modTypeOption) = parameter in + let (leading, trailing) = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc leading; + begin match modTypeOption with + | None -> attach t.trailing lbl.loc trailing + | Some modType -> + let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let (before, inside, after) = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after; + end + + and walkModType modType t comments = + match modType.pmty_desc with + | Pmty_ident longident | Pmty_alias longident -> + let (leading, trailing) = partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing; + | Pmty_signature [] -> + attach t.inside modType.pmty_loc comments + | Pmty_signature signature -> + walkSignature signature t comments + | Pmty_extension extension -> + walkExtension extension t comments + | Pmty_typeof modExpr -> + let (before, inside, after) = partitionByLoc comments modExpr.pmod_loc in + attach t.leading modExpr.pmod_loc before; + walkModExpr modExpr t inside; + attach t.trailing modExpr.pmod_loc after; + | Pmty_with (modType, _withConstraints) -> + let (before, inside, after) = partitionByLoc comments modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after + (* TODO: withConstraints*) + | Pmty_functor _ -> + let (parameters, returnModType) = functorType modType in + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun + (_, lbl, modTypeOption) -> match modTypeOption with + | None -> lbl.Asttypes.loc + | Some modType -> + if lbl.txt = "_" then modType.Parsetree.pmty_loc + else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + ) + ~walkNode:walkModTypeParameter + ~newlineDelimited:false + parameters + t + comments + in + let (before, inside, after) = partitionByLoc comments returnModType.pmty_loc in + attach t.leading returnModType.pmty_loc before; + walkModType returnModType t inside; + attach t.trailing returnModType.pmty_loc after + + and walkModTypeParameter (_, lbl, modTypeOption) t comments = + let (leading, trailing) = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc leading; + begin match modTypeOption with + | None -> attach t.trailing lbl.loc trailing + | Some modType -> + let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc trailing in + attach t.trailing lbl.loc afterLbl; + let (before, inside, after) = partitionByLoc rest modType.pmty_loc in + attach t.leading modType.pmty_loc before; + walkModType modType t inside; + attach t.trailing modType.pmty_loc after; + end + + and walkPattern pat t comments = + let open Location in + match pat.Parsetree.ppat_desc with + | _ when comments = [] -> () + | Ppat_alias (pat, alias) -> + let (leading, inside, trailing) = partitionByLoc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + let (afterPat, rest) = partitionAdjacentTrailing pat.ppat_loc trailing in + attach t.leading pat.ppat_loc leading; + attach t.trailing pat.ppat_loc afterPat; + let (beforeAlias, afterAlias) = partitionLeadingTrailing rest alias.loc in + attach t.leading alias.loc beforeAlias; + attach t.trailing alias.loc afterAlias + | Ppat_tuple [] + | Ppat_array [] + | Ppat_construct({txt = Longident.Lident "()"}, _) + | Ppat_construct({txt = Longident.Lident "[]"}, _) -> + attach t.inside pat.ppat_loc comments; + | Ppat_array patterns -> + walkList + ~getLoc:(fun n -> n.Parsetree.ppat_loc) + ~walkNode:walkPattern + patterns + t + comments + | Ppat_tuple patterns -> + walkList + ~getLoc:(fun n -> n.Parsetree.ppat_loc) + ~walkNode:walkPattern + patterns + t + comments + | Ppat_construct({txt = Longident.Lident "::"}, _) -> + walkList + ~getLoc:(fun n -> n.Parsetree.ppat_loc) + ~walkNode:walkPattern + (collectListPatterns [] pat) + t + comments + | Ppat_construct (constr, None) -> + let (beforeConstr, afterConstr) = + partitionLeadingTrailing comments constr.loc + in + attach t.leading constr.loc beforeConstr; + attach t.trailing constr.loc afterConstr + | Ppat_construct (constr, Some pat) -> + let (leading, trailing) = partitionLeadingTrailing comments constr.loc in + attach t.leading constr.loc leading; + let (afterConstructor, rest) = + partitionAdjacentTrailing constr.loc trailing + in + attach t.trailing constr.loc afterConstructor; + let (leading, inside, trailing) = partitionByLoc rest pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walkPattern pat t inside; + attach t.trailing pat.ppat_loc trailing + | Ppat_variant (_label, None) -> + () + | Ppat_variant (_label, Some pat) -> + walkPattern pat t comments + | Ppat_type _ -> + () + | Ppat_record (recordRows, _) -> + walkList + ~getLoc:(fun ( + (longidentLoc, pattern): (Longident.t Asttypes.loc * Parsetree.pattern) + ) -> { + longidentLoc.loc with + loc_end = pattern.Parsetree.ppat_loc.loc_end + }) + ~walkNode:walkPatternRecordRow + recordRows + t + comments + | Ppat_or (pattern1, pattern2) -> + let (beforePattern1, insidePattern1, afterPattern1) = + partitionByLoc comments pattern1.ppat_loc + in + attach t.leading pattern1.ppat_loc beforePattern1; + walkPattern pattern1 t insidePattern1; + let (afterPattern1, rest) = + partitionAdjacentTrailing pattern1.ppat_loc afterPattern1 + in + attach t.trailing pattern1.ppat_loc afterPattern1; + let (beforePattern2, insidePattern2, afterPattern2) = + partitionByLoc rest pattern2.ppat_loc + in + attach t.leading pattern2.ppat_loc beforePattern2; + walkPattern pattern2 t insidePattern2; + attach t.trailing pattern2.ppat_loc afterPattern2 + | Ppat_constraint (pattern, typ) -> + let (beforePattern, insidePattern, afterPattern) = + partitionByLoc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc beforePattern; + walkPattern pattern t insidePattern; + let (afterPattern, rest) = + partitionAdjacentTrailing pattern.ppat_loc afterPattern + in + attach t.trailing pattern.ppat_loc afterPattern; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typ.ptyp_loc + in + attach t.leading typ.ptyp_loc beforeTyp; + walkTypExpr typ t insideTyp; + attach t.trailing typ.ptyp_loc afterTyp + | Ppat_lazy pattern | Ppat_exception pattern -> + let (leading, inside, trailing) = partitionByLoc comments pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing + | Ppat_unpack stringLoc -> + let (leading, trailing) = partitionLeadingTrailing comments stringLoc.loc in + attach t.leading stringLoc.loc leading; + attach t.trailing stringLoc.loc trailing + | Ppat_extension extension -> + walkExtension extension t comments + | _ -> () + + (* name: firstName *) + and walkPatternRecordRow row t comments = + match row with + (* punned {x}*) + | ({Location.txt=Longident.Lident ident; loc = longidentLoc}, + {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt -> + let (beforeLbl, afterLbl) = + partitionLeadingTrailing comments longidentLoc + in + attach t.leading longidentLoc beforeLbl; + attach t.trailing longidentLoc afterLbl + | (longident, pattern) -> + let (beforeLbl, afterLbl) = + partitionLeadingTrailing comments longident.loc + in + attach t.leading longident.loc beforeLbl; + let (afterLbl, rest) = partitionAdjacentTrailing longident.loc afterLbl in + attach t.trailing longident.loc afterLbl; + let (leading, inside, trailing) = partitionByLoc rest pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walkPattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing + + and walkTypExpr typ t comments = + match typ.Parsetree.ptyp_desc with + | _ when comments = [] -> () + | Ptyp_tuple typexprs -> + walkList + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkTypExpr + typexprs + t + comments + | Ptyp_extension extension -> + walkExtension extension t comments + | Ptyp_package packageType -> + walkPackageType packageType t comments + | Ptyp_alias (typexpr, _alias) -> + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp; + | Ptyp_poly (strings, typexpr) -> + let comments = visitListButContinueWithRemainingComments + ~getLoc:(fun n -> n.Asttypes.loc) + ~walkNode:(fun longident t comments -> + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident + ) + ~newlineDelimited:false + strings + t + comments + in + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + | Ptyp_constr (longident, typexprs) -> + let (beforeLongident, _afterLongident) = + partitionLeadingTrailing comments longident.loc in + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc comments in + attach t.leading longident.loc beforeLongident; + attach t.trailing longident.loc afterLongident; + walkList + ~getLoc:(fun n -> n.Parsetree.ptyp_loc) + ~walkNode:walkTypExpr + typexprs + t + rest + | Ptyp_arrow _ -> + let (_, parameters, typexpr) = arrowType typ in + let comments = walkTypeParameters parameters t comments in + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + | Ptyp_object (fields, _) -> + walkTypObjectFields fields t comments + | _ -> () + + and walkTypObjectFields fields t comments = + walkList + ~getLoc:(fun field -> + match field with + | Parsetree.Otag (lbl, _, typ) -> + {lbl.loc with loc_end = typ.ptyp_loc.loc_end} + | _ -> Location.none + ) + ~walkNode:walkTypObjectField + fields + t + comments + + and walkTypObjectField field t comments = + match field with + | Otag (lbl, _, typexpr) -> + let (beforeLbl, afterLbl) = partitionLeadingTrailing comments lbl.loc in + attach t.leading lbl.loc beforeLbl; + let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc afterLbl in + attach t.trailing lbl.loc afterLbl; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + | _ -> () + + and walkTypeParameters typeParameters t comments = + visitListButContinueWithRemainingComments + ~getLoc:(fun (_, _, typexpr) -> + match typexpr.Parsetree.ptyp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> + {loc with loc_end = typexpr.ptyp_loc.loc_end} + | _ -> + typexpr.ptyp_loc + ) + ~walkNode:walkTypeParameter + ~newlineDelimited:false + typeParameters + t + comments + + and walkTypeParameter (_attrs, _lbl, typexpr) t comments = + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc comments typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp + + and walkPackageType packageType t comments = + let (longident, packageConstraints) = packageType in + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + walkPackageConstraints packageConstraints t rest + + and walkPackageConstraints packageConstraints t comments = + walkList + ~getLoc:(fun (longident, typexpr) -> {longident.Asttypes.loc with + loc_end = typexpr.Parsetree.ptyp_loc.loc_end + }) + ~walkNode:walkPackageConstraint + packageConstraints + t + comments + + and walkPackageConstraint packageConstraint t comments = + let (longident, typexpr) = packageConstraint in + let (beforeLongident, afterLongident) = + partitionLeadingTrailing comments longident.loc in + attach t.leading longident.loc beforeLongident; + let (afterLongident, rest) = + partitionAdjacentTrailing longident.loc afterLongident in + attach t.trailing longident.loc afterLongident; + let (beforeTyp, insideTyp, afterTyp) = + partitionByLoc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc beforeTyp; + walkTypExpr typexpr t insideTyp; + attach t.trailing typexpr.ptyp_loc afterTyp; + + and walkExtension extension t comments = + let (id, payload) = extension in + let (beforeId, afterId) = partitionLeadingTrailing comments id.loc in + attach t.leading id.loc beforeId; + let (afterId, rest) = partitionAdjacentTrailing id.loc afterId in + attach t.trailing id.loc afterId; + walkPayload payload t rest + + and walkAttribute (id, payload) t comments = + let (beforeId, afterId) = partitionLeadingTrailing comments id.loc in + attach t.leading id.loc beforeId; + let (afterId, rest) = partitionAdjacentTrailing id.loc afterId in + attach t.trailing id.loc afterId; + walkPayload payload t rest + + and walkPayload payload t comments = + match payload with + | PStr s -> walkStructure s t comments + | _ -> () diff --git a/analysis/src/vendor/res_outcome_printer/res_core.ml b/analysis/src/vendor/res_outcome_printer/res_core.ml new file mode 100644 index 000000000..940223486 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_core.ml @@ -0,0 +1,6371 @@ +module Doc = Res_doc +module Grammar = Res_grammar +module Token = Res_token +module Diagnostics = Res_diagnostics +module CommentTable = Res_comments_table +module ResPrinter = Res_printer +module Scanner = Res_scanner +module JsFfi = Res_js_ffi +module Parser = Res_parser + +let mkLoc startLoc endLoc = Location.{ + loc_start = startLoc; + loc_end = endLoc; + loc_ghost = false; +} + +module Recover = struct + let defaultExpr () = + let id = Location.mknoloc "rescript.exprhole" in + Ast_helper.Exp.mk (Pexp_extension (id, PStr [])) + + let defaultType () = + let id = Location.mknoloc "rescript.typehole" in + Ast_helper.Typ.extension (id, PStr []) + + let defaultPattern () = + let id = Location.mknoloc "rescript.patternhole" in + Ast_helper.Pat.extension (id, PStr []) + + let defaultModuleExpr () = Ast_helper.Mod.structure [] + let defaultModuleType () = Ast_helper.Mty.signature [] + + let defaultSignatureItem = + let id = Location.mknoloc "rescript.sigitemhole" in + Ast_helper.Sig.extension (id, PStr []) + + let recoverEqualGreater p = + Parser.expect EqualGreater p; + match p.Parser.token with + | MinusGreater -> Parser.next p + | _ -> () + + let shouldAbortListParse p = + let rec check breadcrumbs = + match breadcrumbs with + | [] -> false + | (grammar, _)::rest -> + if Grammar.isPartOfList grammar p.Parser.token then + true + else + check rest + in + check p.breadcrumbs +end + +module ErrorMessages = struct + let listPatternSpread = "List pattern matches only supports one `...` spread, at the end.\n\ +Explanation: a list spread at the tail is efficient, but a spread in the middle would create new list[s]; out of performance concern, our pattern matching currently guarantees to never create new intermediate data." + + let recordPatternSpread = "Record's `...` spread is not supported in pattern matches.\n\ +Explanation: you can't collect a subset of a record's field into its own record, since a record needs an explicit declaration and that subset wouldn't have one.\n\ +Solution: you need to pull out each field you want explicitly." + + (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) + [@@live] + + let arrayPatternSpread = "Array's `...` spread is not supported in pattern matches.\n\ +Explanation: such spread would create a subarray; out of performance concern, our pattern matching currently guarantees to never create new intermediate data.\n\ +Solution: if it's to validate the first few elements, use a `when` clause + Array size check + `get` checks on the current pattern. If it's to obtain a subarray, use `Array.sub` or `Belt.Array.slice`." + + let arrayExprSpread = "Arrays can't use the `...` spread currently. Please use `concat` or other Array helpers." + + let recordExprSpread = "Records can only have one `...` spread, at the beginning.\n\ +Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway." + + let listExprSpread = "Lists can only have one `...` spread, and at the end.\n\ +Explanation: lists are singly-linked list, where a node contains a value and points to the next node. `list[a, ...bc]` efficiently creates a new item and links `bc` as its next nodes. `[...bc, a]` would be expensive, as it'd need to traverse `bc` and prepend each item to `a` one by one. We therefore disallow such syntax sugar.\n\ +Solution: directly use `concat`." + + let variantIdent = "A polymorphic variant (e.g. #id) must start with an alphabetical letter or be a number (e.g. #742)" + + let experimentalIfLet expr = + let switchExpr = {expr with Parsetree.pexp_attributes = []} in + Doc.concat [ + Doc.text "If-let is currently highly experimental."; + Doc.line; + Doc.text "Use a regular `switch` with pattern matching instead:"; + Doc.concat [ + Doc.hardLine; + Doc.hardLine; + ResPrinter.printExpression switchExpr (CommentTable.empty); + ] + ] |> Doc.toString ~width:80 + + let typeParam = "A type param consists of a singlequote followed by a name like `'a` or `'A`" + let typeVar = "A type variable consists of a singlequote followed by a name like `'a` or `'A`" + + let attributeWithoutNode (attr : Parsetree.attribute) = + let ({Asttypes.txt = attrName}, _) = attr in + "Did you forget to attach `" ^ attrName ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" ^ attrName ^"`" + + let typeDeclarationNameLongident longident = + "A type declaration's name cannot contain a module access. Did you mean `" ^ (Longident.last longident) ^"`?" + + let tupleSingleElement = "A tuple needs at least two elements" + + let missingTildeLabeledParameter name = + if name = "" then + "A labeled parameter starts with a `~`." + else + ("A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?") + + let stringInterpolationInPattern = + "String interpolation is not supported in pattern matching." + + let spreadInRecordDeclaration = + "A record type declaration doesn't support the ... spread. Only an object (with quoted field names) does." + + let objectQuotedFieldName name = + "An object type declaration needs quoted field names. Did you mean \"" ^ name ^ "\"?" + + let forbiddenInlineRecordDeclaration = + "An inline record type declaration is only allowed in a variant constructor's declaration" + + let sameTypeSpread = + "You're using a ... spread without extra fields. This is the same type." + + let polyVarIntWithSuffix number = + "A numeric polymorphic variant cannot be followed by a letter. Did you mean `#" ^ number ^ "`?" +end + + +let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) +let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr []) +let ternaryAttr = (Location.mknoloc "ns.ternary", Parsetree.PStr []) +let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr []) +let suppressFragileMatchWarningAttr = (Location.mknoloc "warning", Parsetree.PStr [Ast_helper.Str.eval (Ast_helper.Exp.constant (Pconst_string ("-4", None)))]) +let makeBracesAttr loc = (Location.mkloc "ns.braces" loc, Parsetree.PStr []) + +type stringLiteralState = + | Start + | Backslash + | HexEscape + | DecimalEscape + | OctalEscape + | EscapedLineBreak + +type typDefOrExt = + | TypeDef of {recFlag: Asttypes.rec_flag; types: Parsetree.type_declaration list} + | TypeExt of Parsetree.type_extension + +type labelledParameter = + | TermParameter of + {uncurried: bool; attrs: Parsetree.attributes; label: Asttypes.arg_label; expr: Parsetree.expression option; + pat: Parsetree.pattern; pos: Lexing.position} + | TypeParameter of {uncurried: bool; attrs: Parsetree.attributes; locs: string Location.loc list; pos: Lexing.position} + +type recordPatternItem = + | PatUnderscore + | PatField of (Ast_helper.lid * Parsetree.pattern) + +type context = + | OrdinaryExpr + | TernaryTrueBranchExpr + | WhenExpr + +let getClosingToken = function + | Token.Lparen -> Token.Rparen + | Lbrace -> Rbrace + | Lbracket -> Rbracket + | List -> Rbrace + | LessThan -> GreaterThan + | _ -> assert false + +let rec goToClosing closingToken state = + match (state.Parser.token, closingToken) with + | (Rparen, Token.Rparen) | (Rbrace, Rbrace) | (Rbracket, Rbracket) | (GreaterThan, GreaterThan) -> + Parser.next state; + () + | (Token.Lbracket | Lparen | Lbrace | List | LessThan) as t, _ -> + Parser.next state; + goToClosing (getClosingToken t) state; + goToClosing closingToken state + | ((Rparen | Token.Rbrace | Rbracket | Eof), _) -> + () (* TODO: how do report errors here? *) + | _ -> + Parser.next state; + goToClosing closingToken state + +(* Madness *) +let isEs6ArrowExpression ~inTernary p = + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lident _ | Underscore -> + Parser.next state; + begin match state.Parser.token with + (* Don't think that this valid + * Imagine: let x = (a: int) + * This is a parenthesized expression with a type constraint, wait for + * the arrow *) + (* | Colon when not inTernary -> true *) + | EqualGreater -> true + | _ -> false + end + | Lparen -> + let prevEndPos = state.prevEndPos in + Parser.next state; + begin match state.token with + (* arrived at `()` here *) + | Rparen -> + Parser.next state; + begin match state.Parser.token with + (* arrived at `() :` here *) + | Colon when not inTernary -> + Parser.next state; + begin match state.Parser.token with + (* arrived at `() :typ` here *) + | Lident _ -> + Parser.next state; + begin match state.Parser.token with + (* arrived at `() :typ<` here *) + | LessThan -> + Parser.next state; + goToClosing GreaterThan state; + | _ -> () + end; + begin match state.Parser.token with + (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + | EqualGreater -> + true + | _ -> false + end + | _ -> true + end + | EqualGreater -> true + | _ -> false + end + | Dot (* uncurried *) -> true + | Tilde -> true + | Backtick -> false (* (` always indicates the start of an expr, can't be es6 parameter *) + | _ -> + goToClosing Rparen state; + begin match state.Parser.token with + | EqualGreater -> true + (* | Lbrace TODO: detect missing =>, is this possible? *) + | Colon when not inTernary -> true + | Rparen -> + (* imagine having something as : + * switch colour { + * | Red + * when l == l' + * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) + * We'll arrive at the outer rparen just before the =>. + * This is not an es6 arrow. + * *) + false + | _ -> + Parser.next state; + (* error recovery, peek at the next token, + * (elements, providerId] => { + * in the example above, we have an unbalanced ] here + *) + begin match state.Parser.token with + | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum -> true + | _ -> false + end + end + end + | _ -> false) + + +let isEs6ArrowFunctor p = + Parser.lookahead p (fun state -> + match state.Parser.token with + (* | Uident _ | Underscore -> *) + (* Parser.next state; *) + (* begin match state.Parser.token with *) + (* | EqualGreater -> true *) + (* | _ -> false *) + (* end *) + | Lparen -> + Parser.next state; + begin match state.token with + | Rparen -> + Parser.next state; + begin match state.token with + | Colon | EqualGreater -> true + | _ -> false + end + | _ -> + goToClosing Rparen state; + begin match state.Parser.token with + | EqualGreater | Lbrace -> true + | Colon -> true + | _ -> false + end + end + | _ -> false + ) + +let isEs6ArrowType p = + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lparen -> + Parser.next state; + begin match state.Parser.token with + | Rparen -> + Parser.next state; + begin match state.Parser.token with + | EqualGreater -> true + | _ -> false + end + | Tilde | Dot -> true + | _ -> + goToClosing Rparen state; + begin match state.Parser.token with + | EqualGreater -> true + | _ -> false + end + end + | Tilde -> true + | _ -> false + ) + +let buildLongident words = match List.rev words with + | [] -> assert false + | hd::tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl + +let makeInfixOperator p token startPos endPos = + let stringifiedToken = + if token = Token.MinusGreater then "|." + else if token = Token.PlusPlus then "^" + else if token = Token.BangEqual then "<>" + else if token = Token.BangEqualEqual then "!=" + else if token = Token.Equal then ( + (* TODO: could have a totally different meaning like x->fooSet(y)*) + Parser.err ~startPos ~endPos p ( + Diagnostics.message "Did you mean `==` here?" + ); + "=" + ) else if token = Token.EqualEqual then "=" + else if token = Token.EqualEqualEqual then "==" + else Token.toString token + in + let loc = mkLoc startPos endPos in + let operator = Location.mkloc + (Longident.Lident stringifiedToken) loc + in + Ast_helper.Exp.ident ~loc operator + +let negateString s = + if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' + then (String.sub [@doesNotRaise]) s 1 (String.length s - 1) + else "-" ^ s + +let makeUnaryExpr startPos tokenEnd token operand = + match token, operand.Parsetree.pexp_desc with + | (Token.Plus | PlusDot), Pexp_constant((Pconst_integer _ | Pconst_float _)) -> + operand + | Minus, Pexp_constant(Pconst_integer (n,m)) -> + {operand with pexp_desc = Pexp_constant(Pconst_integer (negateString n,m))} + | (Minus | MinusDot), Pexp_constant(Pconst_float (n,m)) -> + {operand with pexp_desc = Pexp_constant(Pconst_float (negateString n,m))} + | (Token.Plus | PlusDot | Minus | MinusDot ), _ -> + let tokenLoc = mkLoc startPos tokenEnd in + let operator = "~" ^ Token.toString token in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident operator) tokenLoc)) + [Nolabel, operand] + | Token.Bang, _ -> + let tokenLoc = mkLoc startPos tokenEnd in + Ast_helper.Exp.apply + ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:tokenLoc + (Location.mkloc (Longident.Lident "not") tokenLoc)) + [Nolabel, operand] + | _ -> + operand + +let makeListExpression loc seq extOpt = + let rec handleSeq = function + | [] -> + begin match extOpt with + | Some ext -> ext + | None -> + let loc = {loc with Location.loc_ghost = true} in + let nil = Location.mkloc (Longident.Lident "[]") loc in + Ast_helper.Exp.construct ~loc nil None + end + | e1 :: el -> + let exp_el = handleSeq el in + let loc = mkLoc + e1.Parsetree.pexp_loc.Location.loc_start + exp_el.pexp_loc.loc_end + in + let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "::") loc) + (Some arg) + in + let expr = handleSeq seq in + {expr with pexp_loc = loc} + +let makeListPattern loc seq ext_opt = + let rec handle_seq = function + [] -> + let base_case = match ext_opt with + | Some ext -> + ext + | None -> + let loc = { loc with Location.loc_ghost = true} in + let nil = { Location.txt = Longident.Lident "[]"; loc } in + Ast_helper.Pat.construct ~loc nil None + in + base_case + | p1 :: pl -> + let pat_pl = handle_seq pl in + let loc = + mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in + let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in + Ast_helper.Pat.mk ~loc (Ppat_construct(Location.mkloc (Longident.Lident "::") loc, Some arg)) + in + handle_seq seq + +(* TODO: diagnostic reporting *) +let lidentOfPath longident = + match Longident.flatten longident |> List.rev with + | [] -> "" + | ident::_ -> ident + +let makeNewtypes ~attrs ~loc newtypes exp = + let expr = List.fold_right (fun newtype exp -> + Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp)) + ) newtypes exp + in {expr with pexp_attributes = attrs} + +(* locally abstract types syntax sugar + * Transforms + * let f: type t u v. = (foo : list) => ... + * into + * let f = (type t u v. foo : list) => ... + *) +let wrapTypeAnnotation ~loc newtypes core_type body = + let exp = makeNewtypes ~attrs:[] ~loc newtypes + (Ast_helper.Exp.constraint_ ~loc body core_type) + in + let typ = Ast_helper.Typ.poly ~loc newtypes + (Ast_helper.Typ.varify_constructors newtypes core_type) + in + (exp, typ) + +(** + * process the occurrence of _ in the arguments of a function application + * replace _ with a new variable, currently __x, in the arguments + * return a wrapping function that wraps ((__x) => ...) around an expression + * e.g. foo(_, 3) becomes (__x) => foo(__x, 3) + *) +let processUnderscoreApplication args = + let open Parsetree in + let exp_question = ref None in + let hidden_var = "__x" in + let check_arg ((lab, exp) as arg) = + match exp.pexp_desc with + | Pexp_ident ({ txt = Lident "_"} as id) -> + let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in + let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in + exp_question := Some new_exp; + (lab, new_exp) + | _ -> + arg + in + let args = List.map check_arg args in + let wrap exp_apply = + match !exp_question with + | Some {pexp_loc=loc} -> + let pattern = Ast_helper.Pat.mk (Ppat_var (Location.mkloc hidden_var loc)) ~loc in + Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc + | None -> + exp_apply + in + (args, wrap) + +let hexValue x = + match x with + | '0' .. '9' -> + (Char.code x) - 48 + | 'A' .. 'Z' -> + (Char.code x) - 55 + | 'a' .. 'z' -> + (Char.code x) - 97 + | _ -> 16 + +let parseStringLiteral s = + let len = String.length s in + let b = Buffer.create (String.length s) in + + let rec parse state i d = + if i = len then + (match state with + | HexEscape | DecimalEscape | OctalEscape -> false + | _ -> true) + else + let c = String.unsafe_get s i in + match state with + | Start -> + (match c with + | '\\' -> parse Backslash (i + 1) d + | c -> Buffer.add_char b c; parse Start (i + 1) d) + | Backslash -> + (match c with + | 'n' -> Buffer.add_char b '\n'; parse Start (i + 1) d + | 'r' -> Buffer.add_char b '\r'; parse Start (i + 1) d + | 'b' -> Buffer.add_char b '\008'; parse Start (i + 1) d + | 't' -> Buffer.add_char b '\009'; parse Start (i + 1) d + | ('\\' | ' ' | '\'' | '"') as c -> Buffer.add_char b c; parse Start (i + 1) d + | 'x' -> parse HexEscape (i + 1) 0 + | 'o' -> parse OctalEscape (i + 1) 0 + | '0' .. '9' -> parse DecimalEscape i 0 + | '\010' | '\013' -> parse EscapedLineBreak (i + 1) d + | c -> Buffer.add_char b '\\'; Buffer.add_char b c; parse Start (i + 1) d) + | HexEscape -> + if d == 1 then + let c0 = String.unsafe_get s (i - 1) in + let c1 = String.unsafe_get s i in + let c = (16 * (hexValue c0)) + (hexValue c1) in + if c < 0 || c > 255 then false + else ( + Buffer.add_char b (Char.unsafe_chr c); + parse Start (i + 1) 0 + ) + else + parse HexEscape (i + 1) (d + 1) + | DecimalEscape -> + if d == 2 then + let c0 = String.unsafe_get s (i - 2) in + let c1 = String.unsafe_get s (i - 1) in + let c2 = String.unsafe_get s i in + let c = 100 * (Char.code c0 - 48) + 10 * (Char.code c1 - 48) + (Char.code c2 - 48) in + if c < 0 || c > 255 then false + else ( + Buffer.add_char b (Char.unsafe_chr c); + parse Start (i + 1) 0 + ) + else + parse DecimalEscape (i + 1) (d + 1) + | OctalEscape -> + if d == 2 then + let c0 = String.unsafe_get s (i - 2) in + let c1 = String.unsafe_get s (i - 1) in + let c2 = String.unsafe_get s i in + let c = 64 * (Char.code c0 - 48) + 8 * (Char.code c1 - 48) + (Char.code c2 - 48) in + if c < 0 || c > 255 then false + else ( + Buffer.add_char b (Char.unsafe_chr c); + parse Start (i + 1) 0 + ) + else + parse OctalEscape (i + 1) (d + 1) + | EscapedLineBreak -> + (match c with + | ' ' | '\t' -> parse EscapedLineBreak (i + 1) d + | c -> Buffer.add_char b c; parse Start (i + 1) d) + in + if parse Start 0 0 then Buffer.contents b else s + +let rec parseLident p = + let recoverLident p = + if ( + Token.isKeyword p.Parser.token && + p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum + ) + then ( + Parser.err p (Diagnostics.lident p.Parser.token); + Parser.next p; + None + ) else ( + let rec loop p = + if not (Recover.shouldAbortListParse p) + then begin + Parser.next p; + loop p + end + in + Parser.next p; + loop p; + match p.Parser.token with + | Lident _ -> Some () + | _ -> None + ) + in + let startPos = p.Parser.startPos in + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) + | _ -> + begin match recoverLident p with + | Some () -> + parseLident p + | None -> + ("_", mkLoc startPos p.prevEndPos) + end + +let parseIdent ~msg ~startPos p = + match p.Parser.token with + | Lident ident + | Uident ident -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + (ident, loc) + | token when Token.isKeyword token && + p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let tokenTxt = Token.toString token in + let msg = + "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt ^ "\"" + in + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + (tokenTxt, mkLoc startPos p.prevEndPos) + | _token -> + Parser.err ~startPos p (Diagnostics.message msg); + Parser.next p; + ("", mkLoc startPos p.prevEndPos) + +let parseHashIdent ~startPos p = + Parser.expect Hash p; + match p.token with + | String text -> + let text = if p.mode = ParseForTypeChecker then parseStringLiteral text else text in + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int {i; suffix} -> + let () = match suffix with + | Some _ -> + Parser.err p (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) + | _ -> + parseIdent ~startPos ~msg:ErrorMessages.variantIdent p + +(* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) +let parseValuePath p = + let startPos = p.Parser.startPos in + let rec aux p path = + match p.Parser.token with + | Lident ident -> Longident.Ldot(path, ident) + | Uident uident -> + Parser.next p; + Parser.expect Dot p; + aux p (Ldot (path, uident)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Longident.Lident "_" + in + let ident = match p.Parser.token with + | Lident ident -> Longident.Lident ident + | Uident ident -> + Parser.next p; + Parser.expect Dot p; + aux p (Lident ident) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Longident.Lident "_" + in + Parser.next p; + Location.mkloc ident (mkLoc startPos p.prevEndPos) + +let parseValuePathTail p startPos ident = + let rec loop p path = + match p.Parser.token with + | Lident ident -> + Parser.next p; + Location.mkloc (Longident.Ldot(path, ident)) (mkLoc startPos p.prevEndPos) + | Uident ident -> + Parser.next p; + Parser.expect Dot p; + loop p (Longident.Ldot (path, ident)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mknoloc path + in + loop p ident + +let parseModuleLongIdentTail ~lowercase p startPos ident = + let rec loop p acc = + match p.Parser.token with + | Lident ident when lowercase -> + Parser.next p; + let lident = (Longident.Ldot (acc, ident)) in + Location.mkloc lident (mkLoc startPos p.prevEndPos) + | Uident ident -> + Parser.next p; + let endPos = p.prevEndPos in + let lident = (Longident.Ldot (acc, ident)) in + begin match p.Parser.token with + | Dot -> + Parser.next p; + loop p lident + | _ -> Location.mkloc lident (mkLoc startPos endPos) + end + | t -> + Parser.err p (Diagnostics.uident t); + Location.mkloc acc (mkLoc startPos p.prevEndPos) + in + loop p ident + +(* Parses module identifiers: + Foo + Foo.Bar *) +let parseModuleLongIdent ~lowercase p = + (* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *) + let startPos = p.Parser.startPos in + let moduleIdent = match p.Parser.token with + | Lident ident when lowercase -> + let loc = mkLoc startPos p.endPos in + let lident = Longident.Lident ident in + Parser.next p; + Location.mkloc lident loc + | Uident ident -> + let lident = Longident.Lident ident in + let endPos = p.endPos in + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + parseModuleLongIdentTail ~lowercase p startPos lident + | _ -> Location.mkloc lident (mkLoc startPos endPos) + end + | t -> + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) + in + (* Parser.eatBreadcrumb p; *) + moduleIdent + +(* `window.location` or `Math` or `Foo.Bar` *) +let parseIdentPath p = + let rec loop p acc = + match p.Parser.token with + | Uident ident | Lident ident -> + Parser.next p; + let lident = (Longident.Ldot (acc, ident)) in + begin match p.Parser.token with + | Dot -> + Parser.next p; + loop p lident + | _ -> lident + end + | _t -> acc + in + match p.Parser.token with + | Lident ident | Uident ident -> + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + loop p (Longident.Lident ident) + | _ -> Longident.Lident ident + end + | _ -> + Longident.Lident "_" + +let verifyJsxOpeningClosingName p nameExpr = + let closing = match p.Parser.token with + | Lident lident -> Parser.next p; Longident.Lident lident + | Uident _ -> + (parseModuleLongIdent ~lowercase:true p).txt + | _ -> Longident.Lident "" + in + match nameExpr.Parsetree.pexp_desc with + | Pexp_ident openingIdent -> + let opening = + let withoutCreateElement = + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + in + match (Longident.unflatten withoutCreateElement) with + | Some li -> li + | None -> Longident.Lident "" + in + opening = closing + | _ -> assert false + +let string_of_pexp_ident nameExpr = + match nameExpr.Parsetree.pexp_desc with + | Pexp_ident openingIdent -> + Longident.flatten openingIdent.txt + |> List.filter (fun s -> s <> "createElement") + |> String.concat "." + | _ -> "" + +(* open-def ::= + * | open module-path + * | open! module-path *) +let parseOpenDescription ~attrs p = + Parser.leaveBreadcrumb p Grammar.OpenDescription; + let startPos = p.Parser.startPos in + Parser.expect Open p; + let override = if Parser.optional p Token.Bang then + Asttypes.Override + else + Asttypes.Fresh + in + let modident = parseModuleLongIdent ~lowercase:false p in + let loc = mkLoc startPos p.prevEndPos in + Parser.eatBreadcrumb p; + Ast_helper.Opn.mk ~loc ~attrs ~override modident + +let parseTemplateStringLiteral s = + let len = String.length s in + let b = Buffer.create len in + + let rec loop i = + if i < len then + let c = String.unsafe_get s i in + match c with + | '\\' as c -> + if i + 1 < len then + let nextChar = String.unsafe_get s (i + 1) in + begin match nextChar with + | '\\' as c -> + Buffer.add_char b c; + loop (i + 2) + | '$' as c -> + Buffer.add_char b c; + loop (i + 2) + | '`' as c -> + Buffer.add_char b c; + loop (i + 2) + | '\n' | '\r' -> + (* line break *) + loop (i + 2) + | c -> + Buffer.add_char b '\\'; + Buffer.add_char b c; + loop (i + 2) + end + else ( + Buffer.add_char b c + ) + + | c -> + Buffer.add_char b c; + loop (i + 1) + + else + () + in + loop 0; + Buffer.contents b + +(* constant ::= integer-literal *) + (* ∣ float-literal *) + (* ∣ string-literal *) +let parseConstant p = + let isNegative = match p.Parser.token with + | Token.Minus -> Parser.next p; true + | Plus -> Parser.next p; false + | _ -> false + in + let constant = match p.Parser.token with + | Int {i; suffix} -> + let intTxt = if isNegative then "-" ^ i else i in + Parsetree.Pconst_integer (intTxt, suffix) + | Float {f; suffix} -> + let floatTxt = if isNegative then "-" ^ f else f in + Parsetree.Pconst_float (floatTxt, suffix) + | String s -> + let txt = if p.mode = ParseForTypeChecker then + parseStringLiteral s + else + s + in + Pconst_string(txt, None) + | Character c -> Pconst_char c + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Pconst_string("", None) + in + Parser.next p; + constant + +let parseTemplateConstant ~prefix (p : Parser.t) = + (* Arrived at the ` char *) + let startPos = p.startPos in + Parser.nextTemplateLiteralToken p; + match p.token with + | TemplateTail txt -> + Parser.next p; + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + Parsetree.Pconst_string (txt, prefix) + | _ -> + let rec skipTokens () = + Parser.next p; + match p.token with + | Backtick -> Parser.next p; () + | _ -> skipTokens () + in + skipTokens (); + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.stringInterpolationInPattern); + Pconst_string ("", None) + +let parseCommaDelimitedRegion p ~grammar ~closing ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + begin match p.Parser.token with + | Comma -> + Parser.next p; + loop (node::nodes) + | token when token = closing || token = Eof -> + List.rev (node::nodes) + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node::nodes) + | _ -> + if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then + Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node::nodes) + end + | None -> + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ); + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +let parseCommaDelimitedReversedList p ~grammar ~closing ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + begin match p.Parser.token with + | Comma -> + Parser.next p; + loop (node::nodes) + | token when token = closing || token = Eof -> + (node::nodes) + | _ when Grammar.isListElement grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node::nodes) + | _ -> + if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then + Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node::nodes) + end + | None -> + if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then + nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ); + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +let parseDelimitedRegion p ~grammar ~closing ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + loop (node::nodes) + | None -> + if ( + p.Parser.token = Token.Eof || + p.token = closing || + Recover.shouldAbortListParse p + ) then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ) + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +let parseRegion p ~grammar ~f = + Parser.leaveBreadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> + loop (node::nodes) + | None -> + if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes + ) + in + let nodes = loop [] in + Parser.eatBreadcrumb p; + nodes + +(* let-binding ::= pattern = expr *) + (* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr *) + (* ∣ value-name : poly-typexpr = expr *) + + (* pattern ::= value-name *) + (* ∣ _ *) + (* ∣ constant *) + (* ∣ pattern as value-name *) + (* ∣ ( pattern ) *) + (* ∣ ( pattern : typexpr ) *) + (* ∣ pattern | pattern *) + (* ∣ constr pattern *) + (* ∣ #variant variant-pattern *) + (* ∣ #...type *) + (* ∣ / pattern { , pattern }+ / *) + (* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } *) + (* ∣ [ pattern { ; pattern } [ ; ] ] *) + (* ∣ pattern :: pattern *) + (* ∣ [| pattern { ; pattern } [ ; ] |] *) + (* ∣ char-literal .. char-literal *) + (* ∣ exception pattern *) +let rec parsePattern ?(alias=true) ?(or_=true) p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let pat = match p.Parser.token with + | (True | False) as token -> + let endPos = p.endPos in + Parser.next p; + let loc = mkLoc startPos endPos in + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) None + | Int _ | String _ | Float _ | Character _ | Minus | Plus -> + let c = parseConstant p in + begin match p.token with + | DotDot -> + Parser.next p; + let c2 = parseConstant p in + Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 + | _ -> + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c + end + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some "js") p in + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + | Lparen -> + Parser.next p; + begin match p.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct ~loc lid None + | _ -> + let pat = parseConstrainedPattern p in + begin match p.token with + | Comma -> + Parser.next p; + parseTuplePattern ~attrs ~first:pat ~startPos p + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + {pat with ppat_loc = loc} + end + end + | Lbracket -> + parseArrayPattern ~attrs p + | Lbrace -> + parseRecordPattern ~attrs p + | Underscore -> + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + Ast_helper.Pat.any ~loc ~attrs () + | Lident ident -> + let endPos = p.endPos in + let loc = mkLoc startPos endPos in + Parser.next p; + begin match p.token with + | Backtick -> + let constant = parseTemplateConstant ~prefix:(Some ident) p in + Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant + | _ -> + Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) + end + | Uident _ -> + let constr = parseModuleLongIdent ~lowercase:false p in + begin match p.Parser.token with + | Lparen -> + parseConstructorPatternArgs p constr startPos attrs + | _ -> + Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None + end + | Hash -> + Parser.next p; + if p.Parser.token == DotDotDot then ( + Parser.next p; + let ident = parseValuePath p in + let loc = mkLoc startPos ident.loc.loc_end in + Ast_helper.Pat.type_ ~loc ~attrs ident + ) else ( + let (ident, loc) = match p.token with + | String text -> + let text = if p.mode = ParseForTypeChecker then parseStringLiteral text else text in + Parser.next p; + (text, mkLoc startPos p.prevEndPos) + | Int {i; suffix} -> + let () = match suffix with + | Some _ -> + Parser.err p (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) + | None -> () + in + Parser.next p; + (i, mkLoc startPos p.prevEndPos) + | _ -> + parseIdent ~msg:ErrorMessages.variantIdent ~startPos p + in + begin match p.Parser.token with + | Lparen -> + parseVariantPatternArgs p ident startPos attrs + | _ -> + Ast_helper.Pat.variant ~loc ~attrs ident None + end + ) + | Exception -> + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.exception_ ~loc ~attrs pat + | Lazy -> + Parser.next p; + let pat = parsePattern ~alias:false ~or_:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.lazy_ ~loc ~attrs pat + | List -> + Parser.next p; + parseListPattern ~startPos ~attrs p + | Module -> + parseModulePattern ~attrs p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.extension ~loc ~attrs extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart with + | None -> + Recover.defaultPattern() + | Some () -> + parsePattern p + end + in + let pat = if alias then parseAliasPattern ~attrs pat p else pat in + if or_ then parseOrPattern pat p else pat + +and skipTokensAndMaybeRetry p ~isStartOfGrammar = + if Token.isKeyword p.Parser.token + && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum + then ( + Parser.next p; + None + ) else ( + if Recover.shouldAbortListParse p then + begin + if isStartOfGrammar p.Parser.token then + begin + Parser.next p; + Some () + end + else + None + end + else + begin + Parser.next p; + let rec loop p = + if not (Recover.shouldAbortListParse p) + then begin + Parser.next p; + loop p + end in + loop p; + if isStartOfGrammar p.Parser.token then + Some () + else + None + end + ) + +(* alias ::= pattern as lident *) +and parseAliasPattern ~attrs pattern p = + match p.Parser.token with + | As -> + Parser.next p; + let (name, loc) = parseLident p in + let name = Location.mkloc name loc in + Ast_helper.Pat.alias + ~loc:({pattern.ppat_loc with loc_end = p.prevEndPos}) + ~attrs + pattern + name + | _ -> pattern + +(* or ::= pattern | pattern + * precedence: Red | Blue | Green is interpreted as (Red | Blue) | Green *) +and parseOrPattern pattern1 p = + let rec loop pattern1 = + match p.Parser.token with + | Bar -> + Parser.next p; + let pattern2 = parsePattern ~or_:false p in + let loc = { pattern1.Parsetree.ppat_loc with + loc_end = pattern2.ppat_loc.loc_end + } in + loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) + | _ -> pattern1 + in + loop pattern1 + +and parseNonSpreadPattern ~msg p = + let () = match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message msg); + Parser.next p; + | _ -> () + in + match p.Parser.token with + | token when Grammar.isPatternStart token -> + let pat = parsePattern p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Some (Ast_helper.Pat.constraint_ ~loc pat typ) + | _ -> Some pat + end + | _ -> None + +and parseConstrainedPattern p = + let pat = parsePattern p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Ast_helper.Pat.constraint_ ~loc pat typ + | _ -> pat + +and parseConstrainedPatternRegion p = + match p.Parser.token with + | token when Grammar.isPatternStart token -> + Some (parseConstrainedPattern p) + | _ -> None + +(* field ::= + * | longident + * | longident : pattern + * | longident as lident + * + * row ::= + * | field , + * | field , _ + * | field , _, + *) +and parseRecordPatternField p = + let label = parseValuePath p in + let pattern = match p.Parser.token with + | Colon -> + Parser.next p; + parsePattern p + | _ -> + Ast_helper.Pat.var + ~loc:label.loc + (Location.mkloc (Longident.last label.txt) label.loc) + in + (label, pattern) + + (* TODO: there are better representations than PatField|Underscore ? *) +and parseRecordPatternItem p = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + Some (true, PatField (parseRecordPatternField p)) + | Uident _ | Lident _ -> + Some (false, PatField (parseRecordPatternField p)) + | Underscore -> + Parser.next p; + Some (false, PatUnderscore) + | _ -> + None + +and parseRecordPattern ~attrs p = + let startPos = p.startPos in + Parser.expect Lbrace p; + let rawFields = + parseCommaDelimitedReversedList p + ~grammar:PatternRecord + ~closing:Rbrace + ~f:parseRecordPatternItem + in + Parser.expect Rbrace p; + let (fields, closedFlag) = + let (rawFields, flag) = match rawFields with + | (_hasSpread, PatUnderscore)::rest -> + (rest, Asttypes.Open) + | rawFields -> + (rawFields, Asttypes.Closed) + in + List.fold_left (fun (fields, flag) curr -> + let (hasSpread, field) = curr in + match field with + | PatField field -> + if hasSpread then ( + let (_, pattern) = field in + Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message ErrorMessages.recordPatternSpread) + ); + (field::fields, flag) + | PatUnderscore -> + (fields, flag) + ) ([], flag) rawFields + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.record ~loc ~attrs fields closedFlag + +and parseTuplePattern ~attrs ~first ~startPos p = + let patterns = + first::( + parseCommaDelimitedRegion p + ~grammar:Grammar.PatternList + ~closing:Rparen + ~f:parseConstrainedPatternRegion + ) + in + Parser.expect Rparen p; + let () = match patterns with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.tuple ~loc ~attrs (patterns) + +and parsePatternRegion p = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + Some (true, parseConstrainedPattern p) + | token when Grammar.isPatternStart token -> + Some (false, parseConstrainedPattern p) + | _ -> None + +and parseModulePattern ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Module p; + Parser.expect Lparen p; + let uident = match p.token with + | Uident uident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc uident loc + | _ -> (* TODO: error recovery *) + Location.mknoloc "_" + in + begin match p.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let packageTypAttrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in + Ast_helper.Pat.constraint_ + ~loc + ~attrs + unpack + packageType + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.unpack ~loc ~attrs uident + end + +and parseListPattern ~startPos ~attrs p = + let listPatterns = + parseCommaDelimitedReversedList p + ~grammar:Grammar.PatternOcamlList + ~closing:Rbrace + ~f:parsePatternRegion + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let filterSpread (hasSpread, pattern) = + if hasSpread then ( + Parser.err + ~startPos:pattern.Parsetree.ppat_loc.loc_start + p + (Diagnostics.message ErrorMessages.listPatternSpread); + pattern + ) else + pattern + in + match listPatterns with + | (true, pattern)::patterns -> + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns (Some pattern) in + {pat with ppat_loc = loc; ppat_attributes = attrs;} + | patterns -> + let patterns = patterns |> List.map filterSpread |> List.rev in + let pat = makeListPattern loc patterns None in + {pat with ppat_loc = loc; ppat_attributes = attrs;} + +and parseArrayPattern ~attrs p = + let startPos = p.startPos in + Parser.expect Lbracket p; + let patterns = + parseCommaDelimitedRegion + p + ~grammar:Grammar.PatternList + ~closing:Rbracket + ~f:(parseNonSpreadPattern ~msg:ErrorMessages.arrayPatternSpread) + in + Parser.expect Rbracket p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.array ~loc ~attrs patterns + +and parseConstructorPatternArgs p constr startPos attrs = + let lparen = p.startPos in + Parser.expect Lparen p; + let args = parseCommaDelimitedRegion + p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion + in + Parser.expect Rparen p; + let args = match args with + | [] -> + let loc = mkLoc lparen p.prevEndPos in + Some ( + Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None + ) + | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some pat + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [pattern] -> Some pattern + | patterns -> + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + in + Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + +and parseVariantPatternArgs p ident startPos attrs = + let lparen = p.startPos in + Parser.expect Lparen p; + let patterns = + parseCommaDelimitedRegion + p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion in + let args = + match patterns with + | [] -> + let loc = mkLoc lparen p.prevEndPos in + Some ( + Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None + ) + | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> + if p.mode = ParseForTypeChecker then + (* #ident(1, 2) for type-checker *) + Some pat + else + (* #ident((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + | [pattern] -> Some pattern + | patterns -> + Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) + in + Parser.expect Rparen p; + Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args + +and parseExpr ?(context=OrdinaryExpr) p = + let expr = parseOperandExpr ~context p in + let expr = parseBinaryExpr ~context ~a:expr p 1 in + parseTernaryExpr expr p + +(* expr ? expr : expr *) +and parseTernaryExpr leftOperand p = + match p.Parser.token with + | Question -> + Parser.leaveBreadcrumb p Grammar.Ternary; + Parser.next p; + let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in + Parser.expect Colon p; + let falseBranch = parseExpr p in + Parser.eatBreadcrumb p; + let loc = {leftOperand.Parsetree.pexp_loc with + loc_start = leftOperand.pexp_loc.loc_start; + loc_end = falseBranch.Parsetree.pexp_loc.loc_end; + } in + Ast_helper.Exp.ifthenelse + ~attrs:[ternaryAttr] ~loc + leftOperand trueBranch (Some falseBranch) + | _ -> + leftOperand + +and parseEs6ArrowExpression ?context ?parameters p = + let startPos = p.Parser.startPos in + Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; + let parameters = match parameters with + | Some params -> params + | None -> parseParameters p + in + let returnType = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseTypExpr ~es6Arrow:false p) + | _ -> + None + in + Parser.expect EqualGreater p; + let body = + let expr = parseExpr ?context p in + match returnType with + | Some typ -> + Ast_helper.Exp.constraint_ + ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) expr typ + | None -> expr + in + Parser.eatBreadcrumb p; + let endPos = p.prevEndPos in + let arrowExpr = + List.fold_right (fun parameter expr -> + match parameter with + | TermParameter {uncurried; attrs; label = lbl; expr = defaultExpr; pat; pos = startPos} -> + let attrs = if uncurried then uncurryAttr::attrs else attrs in + Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl defaultExpr pat expr + | TypeParameter {uncurried; attrs; locs = newtypes; pos = startPos} -> + let attrs = if uncurried then uncurryAttr::attrs else attrs in + makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr + ) parameters body + in + {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} + +(* + * uncurried_parameter ::= + * | . parameter + * + * parameter ::= + * | pattern + * | pattern : type + * | ~ labelName + * | ~ labelName as pattern + * | ~ labelName as pattern : type + * | ~ labelName = expr + * | ~ labelName as pattern = expr + * | ~ labelName as pattern : type = expr + * | ~ labelName = ? + * | ~ labelName as pattern = ? + * | ~ labelName as pattern : type = ? + * + * labelName ::= lident + *) +and parseParameter p = + if ( + p.Parser.token = Token.Typ || + p.token = Tilde || + p.token = Dot || + Grammar.isPatternStart p.token + ) then ( + let startPos = p.Parser.startPos in + let uncurried = Parser.optional p Token.Dot in + (* two scenarios: + * attrs ~lbl ... + * attrs pattern + * Attributes before a labelled arg, indicate that it's on the whole arrow expr + * Otherwise it's part of the pattern + * *) + let attrs = parseAttributes p in + if p.Parser.token = Typ then ( + Parser.next p; + let lidents = parseLidentList p in + Some (TypeParameter {uncurried; attrs; locs = lidents; pos = startPos}) + ) else ( + let (attrs, lbl, pat) = match p.Parser.token with + | Tilde -> + Parser.next p; + let (lblName, loc) = parseLident p in + let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + begin match p.Parser.token with + | Comma | Equal | Rparen -> + let loc = mkLoc startPos p.prevEndPos in + ( + attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~attrs:[propLocAttr] ~loc (Location.mkloc lblName loc) + ) + | Colon -> + let lblEnd = p.prevEndPos in + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos lblEnd in + let pat = + let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Pat.constraint_ ~attrs:[propLocAttr] ~loc pat typ in + (attrs, Asttypes.Labelled lblName, pat) + | As -> + Parser.next p; + let pat = + let pat = parseConstrainedPattern p in + {pat with ppat_attributes = propLocAttr::pat.ppat_attributes} + in + (attrs, Asttypes.Labelled lblName, pat) + | t -> + Parser.err p (Diagnostics.unexpected t p.breadcrumbs); + let loc = mkLoc startPos p.prevEndPos in + ( + attrs, + Asttypes.Labelled lblName, + Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) + ) + end + | _ -> + let pattern = parseConstrainedPattern p in + let attrs = List.concat [attrs; pattern.ppat_attributes] in + ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) + in + match p.Parser.token with + | Equal -> + Parser.next p; + let lbl = match lbl with + | Asttypes.Labelled lblName -> Asttypes.Optional lblName + | Asttypes.Nolabel -> + let lblName = match pat.ppat_desc with | Ppat_var var -> var.txt | _ -> "" in + Parser.err ~startPos ~endPos:p.prevEndPos p ( + Diagnostics.message (ErrorMessages.missingTildeLabeledParameter lblName) + ); + Asttypes.Optional lblName + | lbl -> lbl + in + begin match p.Parser.token with + | Question -> + Parser.next p; + Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + Some (TermParameter {uncurried; attrs; label = lbl; expr = Some expr; pat; pos = startPos}) + end + | _ -> + Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) + ) + ) else None + +and parseParameterList p = + let parameters = + parseCommaDelimitedRegion + ~grammar:Grammar.ParameterList + ~f:parseParameter + ~closing:Rparen + p + in + Parser.expect Rparen p; + parameters + +(* parameters ::= + * | _ + * | lident + * | () + * | (.) + * | ( parameter {, parameter} [,] ) + *) +and parseParameters p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + [TermParameter { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); + pos = startPos; + }] + | Underscore -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.any ~loc (); pos = startPos}] + | Lparen -> + Parser.next p; + begin match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = Ast_helper.Pat.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + in + [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] + | Dot -> + Parser.next p; + begin match p.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.Parser.prevEndPos in + let unitPattern = Ast_helper.Pat.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + in + [TermParameter {uncurried = true; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] + | _ -> + begin match parseParameterList p with + | (TermParameter {attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest -> + (TermParameter {uncurried = true; attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest + | parameters -> parameters + end + end + | _ -> parseParameterList p + end + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + [] + +and parseCoercedExpr ~(expr: Parsetree.expression) p = + Parser.expect ColonGreaterThan p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start p.prevEndPos in + Ast_helper.Exp.coerce ~loc expr None typ + +and parseConstrainedOrCoercedExpr p = + let expr = parseExpr p in + match p.Parser.token with + | ColonGreaterThan -> + parseCoercedExpr ~expr p + | Colon -> + Parser.next p; + begin match p.token with + | _ -> + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + begin match p.token with + | ColonGreaterThan -> + parseCoercedExpr ~expr p + | _ -> + expr + end + end + | _ -> expr + + +and parseConstrainedExprRegion p = + match p.Parser.token with + | token when Grammar.isExprStart token -> + let expr = parseExpr p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr + end + | _ -> None + +(* Atomic expressions represent unambiguous expressions. + * This means that regardless of the context, these expressions + * are always interpreted correctly. *) +and parseAtomicExpr p = + Parser.leaveBreadcrumb p Grammar.ExprOperand; + let startPos = p.Parser.startPos in + let expr = match p.Parser.token with + | (True | False) as token -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident (Token.toString token)) loc) None + | Int _ | String _ | Float _ | Character _ -> + let c = parseConstant p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constant ~loc c + | Backtick -> + let expr = parseTemplateExpr p in + {expr with pexp_loc = mkLoc startPos p.prevEndPos} + | Uident _ | Lident _ -> + parseValueOrConstructor p + | Hash -> + parsePolyVariantExpr p + | Lparen -> + Parser.next p; + begin match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + | _t -> + let expr = parseConstrainedOrCoercedExpr p in + begin match p.token with + | Comma -> + Parser.next p; + parseTupleExpr ~startPos ~first:expr p + | _ -> + Parser.expect Rparen p; + expr + (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} + * What does this location mean here? It means that when there's + * a parenthesized we keep the location here for whitespace interleaving. + * Without the closing paren in the location there will always be an extra + * line. For now we don't include it, because it does weird things + * with for comments. *) + end + end + | List -> + Parser.next p; + parseListExpr ~startPos p + | Module -> + Parser.next p; + parseFirstClassModuleExpr ~startPos p + | Lbracket -> + parseArrayExp p + | Lbrace -> + parseBracedOrRecordExpr p + | LessThan -> + parseJsx p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.extension ~loc extension + | Underscore as token -> + (* This case is for error recovery. Not sure if it's the correct place *) + Parser.err p (Diagnostics.lident token); + Parser.next p; + Recover.defaultExpr () + | token -> + let errPos = p.prevEndPos in + Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); + begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart with + | None -> Recover.defaultExpr() + | Some () -> parseAtomicExpr p + end + in + Parser.eatBreadcrumb p; + expr + +(* module(module-expr) + * module(module-expr : package-type) *) +and parseFirstClassModuleExpr ~startPos p = + Parser.expect Lparen p; + + let modExpr = parseModuleExpr p in + let modEndLoc = p.prevEndPos in + begin match p.Parser.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos modEndLoc in + let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.constraint_ ~loc firstClassModule packageType + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.pack ~loc modExpr + end + +and parseBracketAccess p expr startPos = + Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; + let lbracket = p.startPos in + Parser.next p; + let stringStart = p.startPos in + match p.Parser.token with + | String s -> + let s = if p.mode = ParseForTypeChecker then parseStringLiteral s else s in + Parser.next p; + let stringEnd = p.prevEndPos in + Parser.expect Rbracket p; + Parser.eatBreadcrumb p; + let rbracket = p.prevEndPos in + let e = + let identLoc = mkLoc stringStart stringEnd in + let loc = mkLoc lbracket rbracket in + Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) + in + let e = parsePrimaryExpr ~operand:e p in + let equalStart = p.startPos in + begin match p.token with + | Equal -> + Parser.next p; + let equalEnd = p.prevEndPos in + let rhsExpr = parseExpr p in + let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in + let operatorLoc = mkLoc equalStart equalEnd in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc:operatorLoc (Location.mkloc (Longident.Lident "#=") operatorLoc)) + [Nolabel, e; Nolabel, rhsExpr] + | _ -> e + end + | _ -> + let accessExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Rbracket p; + Parser.eatBreadcrumb p; + let rbracket = p.prevEndPos in + let arrayLoc = mkLoc lbracket rbracket in + begin match p.token with + | Equal -> + Parser.leaveBreadcrumb p ExprArrayMutation; + Parser.next p; + let rhsExpr = parseExpr p in + let arraySet = Location.mkloc + (Longident.Ldot(Lident "Array", "set")) + arrayLoc + in + let endPos = p.prevEndPos in + let arraySet = Ast_helper.Exp.apply + ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) + [Nolabel, expr; Nolabel, accessExpr; Nolabel, rhsExpr] + in + Parser.eatBreadcrumb p; + arraySet + | _ -> + let endPos = p.prevEndPos in + let e = + Ast_helper.Exp.apply + ~loc:(mkLoc startPos endPos) + (Ast_helper.Exp.ident + ~loc:arrayLoc + (Location.mkloc (Longident.Ldot(Lident "Array", "get")) arrayLoc) + ) + [Nolabel, expr; Nolabel, accessExpr] + in + parsePrimaryExpr ~operand:e p + end + +(* * A primary expression represents + * - atomic-expr + * - john.age + * - array[0] + * - applyFunctionTo(arg1, arg2) + * + * The "operand" represents the expression that is operated on + *) +and parsePrimaryExpr ~operand ?(noCall=false) p = + let startPos = operand.pexp_loc.loc_start in + let rec loop p expr = + match p.Parser.token with + | Dot -> + Parser.next p; + let lident = parseValuePath p in + begin match p.Parser.token with + | Equal when noCall = false -> + Parser.leaveBreadcrumb p Grammar.ExprSetField; + Parser.next p; + let targetExpr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in + Parser.eatBreadcrumb p; + setfield + | _ -> + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + loop p (Ast_helper.Exp.field ~loc expr lident) + end + | Lbracket when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + parseBracketAccess p expr startPos + | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + loop p (parseCallExpr p expr) + | Backtick when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + begin match expr.pexp_desc with + | Pexp_ident {txt = Longident.Lident ident} -> + parseTemplateExpr ~prefix:ident p + | _ -> + Parser.err + ~startPos:expr.pexp_loc.loc_start + ~endPos:expr.pexp_loc.loc_end + p + (Diagnostics.message "Tagged template literals are currently restricted to names like: json`null`."); + parseTemplateExpr p + end + | _ -> expr + in + loop p operand + +(* a unary expression is an expression with only one operand and + * unary operator. Examples: + * -1 + * !condition + * -. 1.6 + *) +and parseUnaryExpr p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | (Minus | MinusDot | Plus | PlusDot | Bang) as token -> + Parser.leaveBreadcrumb p Grammar.ExprUnary; + let tokenEnd = p.endPos in + Parser.next p; + let operand = parseUnaryExpr p in + let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in + Parser.eatBreadcrumb p; + unaryExpr + | _ -> + parsePrimaryExpr ~operand:(parseAtomicExpr p) p + +(* Represents an "operand" in a binary expression. + * If you have `a + b`, `a` and `b` both represent + * the operands of the binary expression with opeartor `+` *) +and parseOperandExpr ~context p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let expr = match p.Parser.token with + | Assert -> + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.assert_ ~loc expr + | Lazy -> + Parser.next p; + let expr = parseUnaryExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.lazy_ ~loc expr + | Try -> + parseTryExpression p + | If -> + parseIfOrIfLetExpression p + | For -> + parseForExpression p + | While -> + parseWhileExpression p + | Switch -> + parseSwitchExpression p + | _ -> + if (context != WhenExpr) && + isEs6ArrowExpression ~inTernary:(context=TernaryTrueBranchExpr) p + then + parseEs6ArrowExpression ~context p + else + parseUnaryExpr p + in + (* let endPos = p.Parser.prevEndPos in *) + {expr with + pexp_attributes = List.concat[expr.Parsetree.pexp_attributes; attrs]; + (* pexp_loc = mkLoc startPos endPos *) + } + +(* a binary expression is an expression that combines two expressions with an + * operator. Examples: + * a + b + * f(x) |> g(y) + *) +and parseBinaryExpr ?(context=OrdinaryExpr) ?a p prec = + let a = match a with + | Some e -> e + | None -> parseOperandExpr ~context p + in + let rec loop a = + let token = p.Parser.token in + let tokenPrec = + match token with + (* Can the minus be interpreted as a binary operator? Or is it a unary? + * let w = { + * x + * -10 + * } + * vs + * let w = { + * width + * - gap + * } + * + * First case is unary, second is a binary operator. + * See Scanner.isBinaryOp *) + | Minus | MinusDot | LessThan when not ( + Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum p.endPos.pos_cnum + ) && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> -1 + | token -> Token.precedence token + in + if tokenPrec < prec then a + else begin + Parser.leaveBreadcrumb p (Grammar.ExprBinaryAfterOp token); + let startPos = p.startPos in + Parser.next p; + let endPos = p.prevEndPos in + let b = parseBinaryExpr ~context p (tokenPrec + 1) in + let loc = mkLoc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in + let expr = Ast_helper.Exp.apply + ~loc + (makeInfixOperator p token startPos endPos) + [Nolabel, a; Nolabel, b] + in + Parser.eatBreadcrumb p; + loop expr + end + in + loop a + +(* If we even need this, determines if < might be the start of jsx. Not 100% complete *) +(* and isStartOfJsx p = *) + (* Parser.lookahead p (fun p -> *) + (* match p.Parser.token with *) + (* | LessThan -> *) + (* Parser.next p; *) + (* begin match p.token with *) + (* | GreaterThan (* <> *) -> true *) + (* | Lident _ | Uident _ | List -> *) + (* ignore (parseJsxName p); *) + (* begin match p.token with *) + (* | GreaterThan (*
*) -> true *) + (* | Question (* true *) + (* | Lident _ | List -> *) + (* Parser.next p; *) + (* begin match p.token with *) + (* | Equal (* true *) + (* | _ -> false (* TODO *) *) + (* end *) + (* | Forwardslash (* *) + (* Parser.next p; *) + (* begin match p.token with *) + (* | GreaterThan (* *) -> true *) + (* | _ -> false *) + (* end *) + (* | _ -> *) + (* false *) + (* end *) + (* | _ -> false *) + (* end *) + (* | _ -> false *) + (* ) *) + +and parseTemplateExpr ?(prefix="js") p = + let hiddenOperator = + let op = Location.mknoloc (Longident.Lident "^") in + Ast_helper.Exp.ident op + in + let rec parseParts acc = + let startPos = p.Parser.startPos in + Parser.nextTemplateLiteralToken p; + match p.token with + | TemplateTail txt -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + if String.length txt > 0 then + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + let str = Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) in + Ast_helper.Exp.apply ~loc hiddenOperator + [Nolabel, acc; Nolabel, str] + else + acc + | TemplatePart txt -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let expr = parseExprBlock p in + let fullLoc = mkLoc startPos p.prevEndPos in + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + let str = Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) in + let next = + let a = if String.length txt > 0 then + Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator [Nolabel, acc; Nolabel, str] + else acc + in + Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator + [Nolabel, a; Nolabel, expr] + in + parseParts next + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string("", None)) + in + let startPos = p.startPos in + Parser.nextTemplateLiteralToken p; + match p.token with + | TemplateTail txt -> + Parser.next p; + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + Ast_helper.Exp.constant ~loc:(mkLoc startPos p.prevEndPos) (Pconst_string(txt, Some prefix)) + | TemplatePart txt -> + Parser.next p; + let constantLoc = mkLoc startPos p.prevEndPos in + let expr = parseExprBlock p in + let fullLoc = mkLoc startPos p.prevEndPos in + let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in + let str = Ast_helper.Exp.constant ~loc:constantLoc (Pconst_string(txt, Some prefix)) in + let next = + if String.length txt > 0 then + Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator [Nolabel, str; Nolabel, expr] + else + expr + in + parseParts next + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.constant (Pconst_string("", None)) + +(* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => + * Also overparse constraints: + * let x = { + * let a = 1 + * a + pi: int + * } + * + * We want to give a nice error message in these cases + * *) +and overParseConstrainedOrCoercedOrArrowExpression p expr = + match p.Parser.token with + | ColonGreaterThan -> + parseCoercedExpr ~expr p + | Colon -> + Parser.next p; + let typ = parseTypExpr ~es6Arrow:false p in + begin match p.Parser.token with + | EqualGreater -> + Parser.next p; + let body = parseExpr p in + let pat = match expr.pexp_desc with + | Pexp_ident longident -> + Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc + (Longident.flatten longident.txt |> String.concat ".") + longident.loc) + (* TODO: can we convert more expressions to patterns?*) + | _ -> + Ast_helper.Pat.var ~loc:expr.pexp_loc (Location.mkloc "pattern" expr.pexp_loc) + in + let arrow1 = Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel + None + pat + (Ast_helper.Exp.constraint_ body typ) + in + let arrow2 = Ast_helper.Exp.fun_ + ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + Asttypes.Nolabel + None + (Ast_helper.Pat.constraint_ pat typ) + body + in + let msg = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "Did you mean to annotate the parameter type or the return type?"; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.text "1) "; + ResPrinter.printExpression arrow1 CommentTable.empty; + Doc.line; + Doc.text "2) "; + ResPrinter.printExpression arrow2 CommentTable.empty; + ] + ) + ] + ) |> Doc.toString ~width:80 + in + Parser.err + ~startPos:expr.pexp_loc.loc_start + ~endPos:body.pexp_loc.loc_end + p + (Diagnostics.message msg); + arrow1 + | _ -> + let open Parsetree in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + let () = Parser.err + ~startPos:expr.pexp_loc.loc_start + ~endPos:typ.ptyp_loc.loc_end + p + (Diagnostics.message + (Doc.breakableGroup ~forceBreak:true (Doc.concat [ + Doc.text "Expressions with type constraints need to be wrapped in parens:"; + Doc.indent ( + Doc.concat [ + Doc.line; + ResPrinter.addParens (ResPrinter.printExpression expr CommentTable.empty); + ] + ) + ]) |> Doc.toString ~width:80 + )) + in + expr + end + | _ -> expr + +and parseLetBindingBody ~startPos ~attrs p = + Parser.beginRegion p; + Parser.leaveBreadcrumb p Grammar.LetBinding; + let pat, exp = + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + match p.Parser.token with + | Colon -> + Parser.next p; + begin match p.token with + | Typ -> (* locally abstract types *) + Parser.next p; + let newtypes = parseLidentList p in + Parser.expect Dot p; + let typ = parseTypExpr p in + Parser.expect Equal p; + let expr = parseExpr p in + let loc = mkLoc startPos p.prevEndPos in + let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in + let pat = Ast_helper.Pat.constraint_ ~loc pat poly in + (pat, exp) + | _ -> + let polyType = parsePolyTypeExpr p in + let loc = {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} in + let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in + Parser.expect Token.Equal p; + let exp = parseExpr p in + let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in + (pat, exp) + end + | _ -> + Parser.expect Token.Equal p; + let exp = overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) in + (pat, exp) + in + let loc = mkLoc startPos p.prevEndPos in + let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in + Parser.eatBreadcrumb p; + Parser.endRegion p; + vb + +(* TODO: find a better way? Is it possible? + * let a = 1 + * @attr + * and b = 2 + * + * The problem is that without semi we need a lookahead to determine + * if the attr is on the letbinding or the start of a new thing + * + * let a = 1 + * @attr + * let b = 1 + * + * Here @attr should attach to something "new": `let b = 1` + * The parser state is forked, which is quite expensive… + *) +and parseAttributesAndBinding (p : Parser.t) = + let err = p.scanner.err in + let ch = p.scanner.ch in + let offset = p.scanner.offset in + let lineOffset = p.scanner.lineOffset in + let lnum = p.scanner.lnum in + let mode = p.scanner.mode in + let token = p.token in + let startPos = p.startPos in + let endPos = p.endPos in + let prevEndPos = p.prevEndPos in + let breadcrumbs = p.breadcrumbs in + let errors = p.errors in + let diagnostics = p.diagnostics in + let comments = p.comments in + + match p.Parser.token with + | At -> + let attrs = parseAttributes p in + begin match p.Parser.token with + | And -> + attrs + | _ -> + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.lineOffset <- lineOffset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.startPos <- startPos; + p.endPos <- endPos; + p.prevEndPos <- prevEndPos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + [] + end + | _ -> [] + +(* definition ::= let [rec] let-binding { and let-binding } *) +and parseLetBindings ~attrs p = + let startPos = p.Parser.startPos in + Parser.optional p Let |> ignore; + let recFlag = if Parser.optional p Token.Rec then + Asttypes.Recursive + else + Asttypes.Nonrecursive + in + let first = parseLetBindingBody ~startPos ~attrs p in + + let rec loop p bindings = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + Parser.next p; + let attrs = match p.token with + | Export -> + let exportLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + genTypeAttr::attrs + | _ -> attrs + in + ignore(Parser.optional p Let); (* overparse for fault tolerance *) + let letBinding = parseLetBindingBody ~startPos ~attrs p in + loop p (letBinding::bindings) + | _ -> + List.rev bindings + in + (recFlag, loop p [first]) + +(* + * div -> div + * Foo -> Foo.createElement + * Foo.Bar -> Foo.Bar.createElement + *) +and parseJsxName p = + let longident = match p.Parser.token with + | Lident ident -> + let identStart = p.startPos in + let identEnd = p.endPos in + Parser.next p; + let loc = mkLoc identStart identEnd in + Location.mkloc (Longident.Lident ident) loc + | Uident _ -> + let longident = parseModuleLongIdent ~lowercase:true p in + Location.mkloc (Longident.Ldot (longident.txt, "createElement")) longident.loc + | _ -> + let msg = "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " + in + Parser.err p (Diagnostics.message msg); + Location.mknoloc (Longident.Lident "_") + in + Ast_helper.Exp.ident ~loc:longident.loc longident + +and parseJsxOpeningOrSelfClosingElement ~startPos p = + let jsxStartPos = p.Parser.startPos in + let name = parseJsxName p in + let jsxProps = parseJsxProps p in + let children = match p.Parser.token with + | Forwardslash -> (* *) + let childrenStartPos = p.Parser.startPos in + Parser.next p; + let childrenEndPos = p.Parser.startPos in + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + makeListExpression loc [] None (* no children *) + | GreaterThan -> (* bar *) + let childrenStartPos = p.Parser.startPos in + Scanner.setJsxMode p.scanner; + Parser.next p; + let (spread, children) = parseJsxChildren p in + let childrenEndPos = p.Parser.startPos in + let () = match p.token with + | LessThanSlash -> Parser.next p + | LessThan -> Parser.next p; Parser.expect Forwardslash p + | token when Grammar.isStructureItemStart token -> () + | _ -> Parser.expect LessThanSlash p + in + begin match p.Parser.token with + | Lident _ | Uident _ when verifyJsxOpeningClosingName p name -> + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + ( match spread, children with + | true, child :: _ -> + child + | _ -> + makeListExpression loc children None + ) + | token -> + let () = if Grammar.isStructureItemStart token then ( + let closing = "" in + let msg = Diagnostics.message ("Missing " ^ closing) in + Parser.err ~startPos ~endPos:p.prevEndPos p msg; + ) else ( + let opening = "" in + let msg = "Closing jsx name should be the same as the opening name. Did you mean " ^ opening ^ " ?" in + Parser.err ~startPos ~endPos:p.prevEndPos p (Diagnostics.message msg); + Parser.expect GreaterThan p + ) + in + let loc = mkLoc childrenStartPos childrenEndPos in + ( match spread, children with + | true, child :: _ -> + child + | _ -> + makeListExpression loc children None + ) + end + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + makeListExpression Location.none [] None + in + let jsxEndPos = p.prevEndPos in + let loc = mkLoc jsxStartPos jsxEndPos in + Ast_helper.Exp.apply + ~loc + name + (List.concat [jsxProps; [ + (Asttypes.Labelled "children", children); + (Asttypes.Nolabel, Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) None) + ]]) + +(* + * jsx ::= + * | <> jsx-children + * | + * | jsx-children + * + * jsx-children ::= primary-expr* * => 0 or more + *) +and parseJsx p = + Parser.leaveBreadcrumb p Grammar.Jsx; + let startPos = p.Parser.startPos in + Parser.expect LessThan p; + let jsxExpr = match p.Parser.token with + | Lident _ | Uident _ -> + parseJsxOpeningOrSelfClosingElement ~startPos p + | GreaterThan -> (* fragment: <> foo *) + parseJsxFragment p + | _ -> + parseJsxName p + in + Parser.eatBreadcrumb p; + {jsxExpr with pexp_attributes = [jsxAttr]} + +(* + * jsx-fragment ::= + * | <> + * | <> jsx-children + *) +and parseJsxFragment p = + let childrenStartPos = p.Parser.startPos in + Scanner.setJsxMode p.scanner; + Parser.expect GreaterThan p; + let (_spread, children) = parseJsxChildren p in + let childrenEndPos = p.Parser.startPos in + Parser.expect LessThanSlash p; + Parser.expect GreaterThan p; + let loc = mkLoc childrenStartPos childrenEndPos in + makeListExpression loc children None + + +(* + * jsx-prop ::= + * | lident + * | ?lident + * | lident = jsx_expr + * | lident = ?jsx_expr + *) +and parseJsxProp p = + match p.Parser.token with + | Question | Lident _ -> + let optional = Parser.optional p Question in + let (name, loc) = parseLident p in + let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + (* optional punning: *) + if optional then + Some ( + Asttypes.Optional name, + Ast_helper.Exp.ident ~attrs:[propLocAttr] + ~loc (Location.mkloc (Longident.Lident name) loc) + ) + else begin + match p.Parser.token with + | Equal -> + Parser.next p; + (* no punning *) + let optional = Parser.optional p Question in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + {e with pexp_attributes = propLocAttr::e.pexp_attributes} + in + let label = + if optional then Asttypes.Optional name else Asttypes.Labelled name + in + Some (label, attrExpr) + | _ -> + let attrExpr = + Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] + (Location.mkloc (Longident.Lident name) loc) in + let label = + if optional then Asttypes.Optional name else Asttypes.Labelled name + in + Some (label, attrExpr) + end + | _ -> + None + +and parseJsxProps p = + parseRegion + ~grammar:Grammar.JsxAttribute + ~f:parseJsxProp + p + +and parseJsxChildren p = + let rec loop p children = + match p.Parser.token with + | Token.Eof | LessThanSlash -> + Scanner.popMode p.scanner Jsx; + List.rev children + | LessThan -> + (* Imagine:
< + * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and + * determines the correct token to disambiguate *) + let token = Scanner.reconsiderLessThan p.scanner in + if token = LessThan then + let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in + loop p (child::children) + else (* LessThanSlash *) + let () = p.token <- token in + let () = Scanner.popMode p.scanner Jsx in + List.rev children + | token when Grammar.isJsxChildStart token -> + let () = Scanner.popMode p.scanner Jsx in + let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in + loop p (child::children) + | _ -> + Scanner.popMode p.scanner Jsx; + List.rev children + in + match p.Parser.token with + | DotDotDot -> + Parser.next p; + (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) + | _ -> (false, loop p []) + +and parseBracedOrRecordExpr p = + let startPos = p.Parser.startPos in + Parser.expect Lbrace p; + match p.Parser.token with + | Rbrace -> + Parser.err p (Diagnostics.unexpected Rbrace p.breadcrumbs); + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + Ast_helper.Exp.construct ~attrs:[braces] ~loc + (Location.mkloc (Longident.Lident "()") loc) None + | DotDotDot -> + (* beginning of record spread, parse record *) + Parser.next p; + let spreadExpr = parseConstrainedOrCoercedExpr p in + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in + Parser.expect Rbrace p; + expr + | String s -> + let s = if p.mode = ParseForTypeChecker then parseStringLiteral s else s in + let field = + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc (Longident.Lident s) loc + in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Parser.optional p Comma |> ignore; + let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in + Parser.expect Rbrace p; + expr + | _ -> + let constant = Ast_helper.Exp.constant ~loc:field.loc (Parsetree.Pconst_string(s, None)) in + let a = parsePrimaryExpr ~operand:constant p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with Parsetree.pexp_attributes = braces::expr.Parsetree.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + end + | Uident _ | Lident _ -> + let valueOrConstructor = parseValueOrConstructor p in + begin match valueOrConstructor.pexp_desc with + | Pexp_ident pathIdent -> + let identEndPos = p.prevEndPos in + begin match p.Parser.token with + | Comma -> + Parser.next p; + let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + Parser.expect Rbrace p; + expr + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + begin match p.token with + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None + | _ -> + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in + Parser.expect Rbrace p; + expr + end + (* error case *) + | Lident _ -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( + Parser.expect Comma p; + let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + Parser.expect Rbrace p; + expr + ) else ( + Parser.expect Colon p; + let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in + Parser.expect Rbrace p; + expr + ) + | Semicolon -> + let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | EqualGreater -> + let loc = mkLoc startPos identEndPos in + let ident = Location.mkloc (Longident.last pathIdent.txt) loc in + let a = parseEs6ArrowExpression + ~parameters:[TermParameter { + uncurried = false; + attrs = []; + label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ident; + pos = startPos; + }] + p + in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + | _ -> + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = parsePrimaryExpr ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + end + | _ -> + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let a = parsePrimaryExpr ~operand:valueOrConstructor p in + let e = parseBinaryExpr ~a p 1 in + let e = parseTernaryExpr e p in + Parser.eatBreadcrumb p; + begin match p.Parser.token with + | Semicolon -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {e with pexp_attributes = braces::e.pexp_attributes} + | _ -> + let expr = parseExprBlock ~first:e p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + end + end + | _ -> + let expr = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let braces = makeBracesAttr loc in + {expr with pexp_attributes = braces::expr.pexp_attributes} + +and parseRecordRowWithStringKey p = + match p.Parser.token with + | String s -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + let field = Location.mkloc (Longident.Lident s) loc in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Some (field, fieldExpr) + | _ -> + Some (field, Ast_helper.Exp.ident ~loc:field.loc field) + end + | _ -> None + +and parseRecordRow p = + let () = match p.Parser.token with + | Token.DotDotDot -> + Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); + Parser.next p; + | _ -> () + in + match p.Parser.token with + | Lident _ | Uident _ -> + let field = parseValuePath p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parseExpr p in + Some (field, fieldExpr) + | _ -> + Some (field, Ast_helper.Exp.ident ~loc:field.loc field) + end + | _ -> None + +and parseRecordExprWithStringKeys ~startPos firstRow p = + let rows = firstRow::( + parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey ~closing:Rbrace ~f:parseRecordRowWithStringKey p + ) in + let loc = mkLoc startPos p.endPos in + let recordStrExpr = Ast_helper.Str.eval ~loc ( + Ast_helper.Exp.record ~loc rows None + ) in + Ast_helper.Exp.extension ~loc + (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr]) + +and parseRecordExpr ~startPos ?(spread=None) rows p = + let exprs = + parseCommaDelimitedRegion + ~grammar:Grammar.RecordRows + ~closing:Rbrace + ~f:parseRecordRow p + in + let rows = List.concat [rows; exprs] in + let () = match rows with + | [] -> + let msg = "Record spread needs at least one field that's updated" in + Parser.err p (Diagnostics.message msg); + | _rows -> () + in + let loc = mkLoc startPos p.endPos in + Ast_helper.Exp.record ~loc rows spread + + +and parseNewlineOrSemicolonExprBlock p = + match p.Parser.token with + | Semicolon -> + Parser.next p + | token when Grammar.isBlockExprStart token -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err + ~startPos:p.prevEndPos + ~endPos: p.endPos + p + (Diagnostics.message "consecutive expressions on a line must be separated by ';' or a newline") + | _ -> () + +and parseExprBlockItem p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Module -> + Parser.next p; + begin match p.token with + | Lparen -> + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + parseTernaryExpr expr p + | _ -> + let name = match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parseModuleBindingBody p in + parseNewlineOrSemicolonExprBlock p; + let expr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.letmodule ~loc name body expr + end + | Exception -> + let extensionConstructor = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr + | Open -> + let od = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = parseExprBlock p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr + | Let -> + let (recFlag, letBindings) = parseLetBindings ~attrs p in + parseNewlineOrSemicolonExprBlock p; + let next = if Grammar.isBlockExprStart p.Parser.token then + parseExprBlock p + else + let loc = mkLoc p.startPos p.endPos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.let_ ~loc recFlag letBindings next + | _ -> + let e1 = + let expr = parseExpr p in + {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} + in + parseNewlineOrSemicolonExprBlock p; + if Grammar.isBlockExprStart p.Parser.token then + let e2 = parseExprBlock p in + let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in + Ast_helper.Exp.sequence ~loc e1 e2 + else e1 + +(* blockExpr ::= expr + * | expr ; + * | expr ; blockExpr + * | module ... ; blockExpr + * | open ... ; blockExpr + * | exception ... ; blockExpr + * | let ... + * | let ... ; + * | let ... ; blockExpr + * + * note: semi should be made optional + * a block of expression is always + *) +and parseExprBlock ?first p = + Parser.leaveBreadcrumb p Grammar.ExprBlock; + let item = match first with + | Some e -> e + | None -> parseExprBlockItem p + in + parseNewlineOrSemicolonExprBlock p; + let blockExpr = if Grammar.isBlockExprStart p.Parser.token then + let next = parseExprBlockItem p in + let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in + Ast_helper.Exp.sequence ~loc item next + else + item + in + Parser.eatBreadcrumb p; + overParseConstrainedOrCoercedOrArrowExpression p blockExpr + +and parseTryExpression p = + let startPos = p.Parser.startPos in + Parser.expect Try p; + let expr = parseExpr ~context:WhenExpr p in + Parser.expect Res_token.catch p; + Parser.expect Lbrace p; + let cases = parsePatternMatching p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.try_ ~loc expr cases + +and parseIfCondition p = + Parser.leaveBreadcrumb p Grammar.IfCondition; + (* doesn't make sense to try es6 arrow here? *) + let conditionExpr = parseExpr ~context:WhenExpr p in + Parser.eatBreadcrumb p; + conditionExpr + +and parseThenBranch p = + Parser.leaveBreadcrumb p IfBranch; + Parser.expect Lbrace p; + let thenExpr = parseExprBlock p in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + thenExpr + +and parseElseBranch p = + Parser.expect Lbrace p; + let blockExpr = parseExprBlock p in + Parser.expect Rbrace p; + blockExpr; + +and parseIfExpr startPos p = + let conditionExpr = parseIfCondition p in + let thenExpr = parseThenBranch p in + let elseExpr = match p.Parser.token with + | Else -> + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = match p.token with + | If -> + parseIfOrIfLetExpression p + | _ -> + parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + Some elseExpr + | _ -> + Parser.endRegion p; + None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr + +and parseIfLetExpr startPos p = + let pattern = parsePattern p in + Parser.expect Equal p; + let conditionExpr = parseIfCondition p in + let thenExpr = parseThenBranch p in + let elseExpr = match p.Parser.token with + | Else -> + Parser.endRegion p; + Parser.leaveBreadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.beginRegion p; + let elseExpr = match p.token with + | If -> + parseIfOrIfLetExpression p + | _ -> + parseElseBranch p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + elseExpr + | _ -> + Parser.endRegion p; + let startPos = p.Parser.startPos in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.match_ ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] ~loc conditionExpr [ + Ast_helper.Exp.case pattern thenExpr; + Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr; + ] + +and parseIfOrIfLetExpression p = + Parser.beginRegion p; + Parser.leaveBreadcrumb p Grammar.ExprIf; + let startPos = p.Parser.startPos in + Parser.expect If p; + let expr = match p.Parser.token with + | Let -> + Parser.next p; + let ifLetExpr = parseIfLetExpr startPos p in + Parser.err + ~startPos:ifLetExpr.pexp_loc.loc_start + ~endPos:ifLetExpr.pexp_loc.loc_end + p + (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); + ifLetExpr + | _ -> + parseIfExpr startPos p + in + Parser.eatBreadcrumb p; + expr; + +and parseForRest hasOpeningParen pattern startPos p = + Parser.expect In p; + let e1 = parseExpr p in + let direction = match p.Parser.token with + | Lident "to" -> Asttypes.Upto + | Lident "downto" -> Asttypes.Downto + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Asttypes.Upto + in + Parser.next p; + let e2 = parseExpr ~context:WhenExpr p in + if hasOpeningParen then Parser.expect Rparen p; + Parser.expect Lbrace p; + let bodyExpr = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.for_ ~loc pattern e1 e2 direction bodyExpr + +and parseForExpression p = + let startPos = p.Parser.startPos in + Parser.leaveBreadcrumb p Grammar.ExprFor; + Parser.expect For p; + Parser.beginRegion p; + let forExpr = match p.token with + | Lparen -> + let lparen = p.startPos in + Parser.next p; + begin match p.token with + | Rparen -> + Parser.next p; + let unitPattern = + let loc = mkLoc lparen p.prevEndPos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct lid None + in + parseForRest false (parseAliasPattern ~attrs:[] unitPattern p) startPos p + | _ -> + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + begin match p.token with + | Comma -> + Parser.next p; + let tuplePattern = + parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p + in + let pattern = parseAliasPattern ~attrs:[] tuplePattern p in + parseForRest false pattern startPos p + | _ -> + parseForRest true pat startPos p + end + end + | _ -> + Parser.leaveBreadcrumb p Grammar.Pattern; + let pat = parsePattern p in + Parser.eatBreadcrumb p; + parseForRest false pat startPos p + in + Parser.eatBreadcrumb p; + Parser.endRegion p; + forExpr + + +and parseWhileExpression p = + let startPos = p.Parser.startPos in + Parser.expect While p; + let expr1 = parseExpr ~context:WhenExpr p in + Parser.expect Lbrace p; + let expr2 = parseExprBlock p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.while_ ~loc expr1 expr2 + +and parsePatternGuard p = + match p.Parser.token with + | When | If -> + Parser.next p; + Some (parseExpr ~context:WhenExpr p) + | _ -> + None + +and parsePatternMatchCase p = + Parser.beginRegion p; + Parser.leaveBreadcrumb p Grammar.PatternMatchCase; + match p.Parser.token with + | Token.Bar -> + Parser.next p; + Parser.leaveBreadcrumb p Grammar.Pattern; + let lhs = parsePattern p in + Parser.eatBreadcrumb p; + let guard = parsePatternGuard p in + let () = match p.token with + | EqualGreater -> Parser.next p + | _ -> Recover.recoverEqualGreater p + in + let rhs = parseExprBlock p in + Parser.endRegion p; + Parser.eatBreadcrumb p; + Some (Ast_helper.Exp.case lhs ?guard rhs) + | _ -> + Parser.endRegion p; + Parser.eatBreadcrumb p; + None + +and parsePatternMatching p = + let cases = + parseDelimitedRegion + ~grammar:Grammar.PatternMatching + ~closing:Rbrace + ~f:parsePatternMatchCase + p + in + let () = match cases with + | [] -> Parser.err ~startPos:p.prevEndPos p ( + Diagnostics.message "Pattern matching needs at least one case" + ) + | _ -> () + in + cases + +and parseSwitchExpression p = + let startPos = p.Parser.startPos in + Parser.expect Switch p; + let switchExpr = parseExpr ~context:WhenExpr p in + Parser.expect Lbrace p; + let cases = parsePatternMatching p in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.match_ ~loc switchExpr cases + +(* + * argument ::= + * | _ (* syntax sugar *) + * | expr + * | expr : type + * | ~ label-name + * | ~ label-name + * | ~ label-name ? + * | ~ label-name = expr + * | ~ label-name = _ (* syntax sugar *) + * | ~ label-name = expr : type + * | ~ label-name = ? expr + * | ~ label-name = ? _ (* syntax sugar *) + * | ~ label-name = ? expr : type + * + * uncurried_argument ::= + * | . argument + *) +and parseArgument p = + if ( + p.Parser.token = Token.Tilde || + p.token = Dot || + p.token = Underscore || + Grammar.isExprStart p.token + ) then ( + match p.Parser.token with + | Dot -> + let uncurried = true in + Parser.next(p); + begin match p.token with + (* apply(.) *) + | Rparen -> + let unitExpr = Ast_helper.Exp.construct + (Location.mknoloc (Longident.Lident "()")) + None + in + Some (uncurried, Asttypes.Nolabel, unitExpr) + | _ -> + parseArgument2 p ~uncurried + end + | _ -> + parseArgument2 p ~uncurried:false + ) else + None + +and parseArgument2 p ~uncurried = + match p.Parser.token with + (* foo(_), do not confuse with foo(_ => x), TODO: performance *) + | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + let exp = Ast_helper.Exp.ident ~loc ( + Location.mkloc (Longident.Lident "_") loc + ) in + Some (uncurried, Asttypes.Nolabel, exp) + | Tilde -> + Parser.next p; + (* TODO: nesting of pattern matches not intuitive for error recovery *) + begin match p.Parser.token with + | Lident ident -> + let startPos = p.startPos in + Parser.next p; + let endPos = p.prevEndPos in + let loc = mkLoc startPos endPos in + let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + let identExpr = Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc ( + Location.mkloc (Longident.Lident ident) loc + ) in + begin match p.Parser.token with + | Question -> + Parser.next p; + Some (uncurried, Asttypes.Optional ident, identExpr) + | Equal -> + Parser.next p; + let label = match p.Parser.token with + | Question -> + Parser.next p; + Asttypes.Optional ident + | _ -> + Labelled ident + in + let expr = match p.Parser.token with + | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Ast_helper.Exp.ident ~loc ( + Location.mkloc (Longident.Lident "_") loc + ) + | _ -> + let expr = parseConstrainedOrCoercedExpr p in + {expr with pexp_attributes = propLocAttr::expr.pexp_attributes} + in + Some (uncurried, label, expr) + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + let expr = Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ in + Some (uncurried, Labelled ident, expr) + | _ -> + Some (uncurried, Labelled ident, identExpr) + end + | t -> + Parser.err p (Diagnostics.lident t); + Some (uncurried, Nolabel, Recover.defaultExpr ()) + end + | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p) + +and parseCallExpr p funExpr = + Parser.expect Lparen p; + let startPos = p.Parser.startPos in + Parser.leaveBreadcrumb p Grammar.ExprCall; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.ArgumentList + ~closing:Rparen + ~f:parseArgument p + in + Parser.expect Rparen p; + let args = match args with + | [] -> + let loc = mkLoc startPos p.prevEndPos in + (* No args -> unit sugar: `foo()` *) + [ false, + Asttypes.Nolabel, + Ast_helper.Exp.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None + ] + | [ + true, + Asttypes.Nolabel, + ({ + pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); + pexp_loc = loc; + pexp_attributes = [] + } as expr) + ] when (not loc.loc_ghost) && p.mode = ParseForTypeChecker -> + (* Since there is no syntax space for arity zero vs arity one, + * we expand + * `fn(. ())` into + * `fn(. {let __res_unit = (); __res_unit})` + * when the parsetree is intended for type checking + * + * Note: + * `fn(.)` is treated as zero arity application. + * The invisible unit expression here has loc_ghost === true + * + * Related: https://github.com/rescript-lang/syntax/issues/138 + *) + [ + true, + Asttypes.Nolabel, + Ast_helper.Exp.let_ + Asttypes.Nonrecursive + [Ast_helper.Vb.mk + (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) + expr] + (Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident "__res_unit"))) + ] + | args -> args + in + let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in + let args = match args with + | (u, lbl, expr)::args -> + let group (grp, acc) (uncurried, lbl, expr) = + let (_u, grp) = grp in + if uncurried == true then + ((true, [lbl, expr]), ((_u, (List.rev grp))::acc)) + else + ((_u, ((lbl, expr)::grp)), acc) + in + let ((_u, grp), acc) = List.fold_left group((u, [lbl, expr]), []) args in + List.rev ((_u, (List.rev grp))::acc) + | [] -> [] + in + let apply = List.fold_left (fun callBody group -> + let (uncurried, args) = group in + let (args, wrap) = processUnderscoreApplication args in + let exp = if uncurried then + let attrs = [uncurryAttr] in + Ast_helper.Exp.apply ~loc ~attrs callBody args + else + Ast_helper.Exp.apply ~loc callBody args + in + wrap exp + ) funExpr args + in + Parser.eatBreadcrumb p; + apply + +and parseValueOrConstructor p = + let startPos = p.Parser.startPos in + let rec aux p acc = + match p.Parser.token with + | Uident ident -> + let endPosLident = p.endPos in + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + aux p (ident::acc) + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let lident = buildLongident (ident::acc) in + let tail = match args with + | [] -> None + | [{Parsetree.pexp_desc = Pexp_tuple _} as arg] as args -> + let loc = mkLoc lparen rparen in + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some arg + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc args) + | [arg] -> + Some arg + | args -> + let loc = mkLoc lparen rparen in + Some (Ast_helper.Exp.tuple ~loc args) + in + let loc = mkLoc startPos p.prevEndPos in + let identLoc = mkLoc startPos endPosLident in + Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail + | _ -> + let loc = mkLoc startPos p.prevEndPos in + let lident = buildLongident (ident::acc) in + Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None + end + | Lident ident -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let lident = buildLongident (ident::acc) in + Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) + | token -> + Parser.next p; + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultExpr() + in + aux p [] + +and parsePolyVariantExpr p = + let startPos = p.startPos in + let (ident, _loc) = parseHashIdent ~startPos p in + begin match p.Parser.token with + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + let lparen = p.startPos in + let args = parseConstructorArgs p in + let rparen = p.prevEndPos in + let loc_paren = mkLoc lparen rparen in + let tail = match args with + | [] -> None + | [{Parsetree.pexp_desc = Pexp_tuple _} as expr ] as args -> + if p.mode = ParseForTypeChecker then + (* #a(1, 2) for type-checker *) + Some expr + else + (* #a((1, 2)) for type-checker *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + | [arg] -> Some arg + | args -> + (* #a((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident tail + | _ -> + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.variant ~loc ident None + end + +and parseConstructorArgs p = + let lparen = p.Parser.startPos in + Parser.expect Lparen p; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.ExprList ~f:parseConstrainedExprRegion ~closing:Rparen p + in + Parser.expect Rparen p; + match args with + | [] -> + let loc = mkLoc lparen p.prevEndPos in + [Ast_helper.Exp.construct + ~loc (Location.mkloc (Longident.Lident "()") loc) None] + | args -> args + +and parseTupleExpr ~first ~startPos p = + let exprs = + first::( + parseCommaDelimitedRegion + p + ~grammar:Grammar.ExprList + ~closing:Rparen + ~f:parseConstrainedExprRegion + ) + in + Parser.expect Rparen p; + let () = match exprs with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Exp.tuple ~loc exprs + +and parseSpreadExprRegion p = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + let expr = parseConstrainedOrCoercedExpr p in + Some (true, expr) + | token when Grammar.isExprStart token -> + Some (false, parseConstrainedOrCoercedExpr p) + | _ -> None + +and parseListExpr ~startPos p = + let listExprs = + parseCommaDelimitedReversedList + p ~grammar:Grammar.ListExpr ~closing:Rbrace ~f:parseSpreadExprRegion + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + match listExprs with + | (true, expr)::exprs -> + let exprs = exprs |> List.map snd |> List.rev in + makeListExpression loc exprs (Some expr) + | exprs -> + let exprs = + exprs + |> List.map (fun (spread, expr) -> + if spread then + Parser.err p (Diagnostics.message ErrorMessages.listExprSpread); + expr) + |> List.rev + in + makeListExpression loc exprs None + +(* Overparse ... and give a nice error message *) +and parseNonSpreadExp ~msg p = + let () = match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message msg); + Parser.next p; + | _ -> () + in + match p.Parser.token with + | token when Grammar.isExprStart token -> + let expr = parseExpr p in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr + end + | _ -> None + +and parseArrayExp p = + let startPos = p.Parser.startPos in + Parser.expect Lbracket p; + let exprs = + parseCommaDelimitedRegion + p + ~grammar:Grammar.ExprList + ~closing:Rbracket + ~f:(parseNonSpreadExp ~msg:ErrorMessages.arrayExprSpread) + in + Parser.expect Rbracket p; + Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) exprs + +(* TODO: check attributes in the case of poly type vars, + * might be context dependend: parseFieldDeclaration (see ocaml) *) +and parsePolyTypeExpr p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | SingleQuote -> + let vars = parseTypeVarList p in + begin match vars with + | _v1::_v2::_ -> + Parser.expect Dot p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | [var] -> + begin match p.Parser.token with + | Dot -> + Parser.next p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.poly ~loc vars typ + | EqualGreater -> + Parser.next p; + let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + | _ -> + Ast_helper.Typ.var ~loc:var.loc var.txt + end + | _ -> assert false + end + | _ -> + parseTypExpr p + +(* 'a 'b 'c *) +and parseTypeVarList p = + let rec loop p vars = + match p.Parser.token with + | SingleQuote -> + Parser.next p; + let (lident, loc) = parseLident p in + let var = Location.mkloc lident loc in + loop p (var::vars) + | _ -> + List.rev vars + in + loop p [] + +and parseLidentList p = + let rec loop p ls = + match p.Parser.token with + | Lident lident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + loop p ((Location.mkloc lident loc)::ls) + | _ -> + List.rev ls + in + loop p [] + +and parseAtomicTypExpr ~attrs p = + Parser.leaveBreadcrumb p Grammar.AtomicTypExpr; + let startPos = p.Parser.startPos in + let typ = match p.Parser.token with + | SingleQuote -> + Parser.next p; + let (ident, loc) = parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p in + Ast_helper.Typ.var ~loc ~attrs ident + | Underscore -> + let endPos = p.endPos in + Parser.next p; + Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () + | Lparen -> + Parser.next p; + begin match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + Ast_helper.Typ.constr ~attrs unitConstr [] + | _ -> + let t = parseTypExpr p in + begin match p.token with + | Comma -> + Parser.next p; + parseTupleType ~attrs ~first:t ~startPos p + | _ -> + Parser.expect Rparen p; + {t with + ptyp_loc = mkLoc startPos p.prevEndPos; + ptyp_attributes = List.concat [attrs; t.ptyp_attributes]} + end + end + | Lbracket -> + parsePolymorphicVariantType ~attrs p + | Uident _ | Lident _ -> + let constr = parseValuePath p in + let args = parseTypeConstructorArgs ~constrName:constr p in + Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + | Module -> + Parser.next p; + Parser.expect Lparen p; + let packageType = parsePackageType ~startPos ~attrs p in + Parser.expect Rparen p; + {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.extension ~attrs ~loc extension + | Lbrace -> + parseRecordOrObjectType ~attrs p + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart with + | Some () -> + parseAtomicTypExpr ~attrs p + | None -> + Parser.err ~startPos:p.prevEndPos p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultType() + end + in + Parser.eatBreadcrumb p; + typ + +(* package-type ::= + | modtype-path + ∣ modtype-path with package-constraint { and package-constraint } + *) +and parsePackageType ~startPos ~attrs p = + let modTypePath = parseModuleLongIdent ~lowercase:true p in + begin match p.Parser.token with + | Lident "with" -> + Parser.next p; + let constraints = parsePackageConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath constraints + | _ -> + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.package ~loc ~attrs modTypePath [] + end + +(* package-constraint { and package-constraint } *) +and parsePackageConstraints p = + let first = + Parser.expect Typ p; + let typeConstr = parseValuePath p in + Parser.expect Equal p; + let typ = parseTypExpr p in + (typeConstr, typ) + in + let rest = parseRegion + ~grammar:Grammar.PackageConstraint + ~f:parsePackageConstraint + p + in + first::rest + +(* and type typeconstr = typexpr *) +and parsePackageConstraint p = + match p.Parser.token with + | And -> + Parser.next p; + Parser.expect Typ p; + let typeConstr = parseValuePath p in + Parser.expect Equal p; + let typ = parseTypExpr p in + Some (typeConstr, typ) + | _ -> None + +and parseRecordOrObjectType ~attrs p = + (* for inline record in constructor *) + let startPos = p.Parser.startPos in + Parser.expect Lbrace p; + let closedFlag = match p.token with + | DotDot -> Parser.next p; Asttypes.Open + | Dot -> Parser.next p; Asttypes.Closed + | _ -> Asttypes.Closed + in + let () = match p.token with + | Lident _ -> + Parser.err p (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) + | _ -> () + in + let startFirstField = p.startPos in + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + in + let () = match fields with + | [Parsetree.Oinherit {ptyp_loc}] -> + (* {...x}, spread without extra fields *) + Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end + (Diagnostics.message ErrorMessages.sameTypeSpread) + | _ -> () + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.object_ ~loc ~attrs fields closedFlag + +(* TODO: check associativity in combination with attributes *) +and parseTypeAlias p typ = + match p.Parser.token with + | As -> + Parser.next p; + Parser.expect SingleQuote p; + let (ident, _loc) = parseLident p in + (* TODO: how do we parse attributes here? *) + Ast_helper.Typ.alias ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) typ ident + | _ -> typ + + +(* type_parameter ::= + * | type_expr + * | ~ident: type_expr + * | ~ident: type_expr=? + * + * note: + * | attrs ~ident: type_expr -> attrs are on the arrow + * | attrs type_expr -> attrs are here part of the type_expr + * + * uncurried_type_parameter ::= + * | . type_parameter + *) +and parseTypeParameter p = + if ( + p.Parser.token = Token.Tilde || + p.token = Dot || + Grammar.isTypExprStart p.token + ) then ( + let startPos = p.Parser.startPos in + let uncurried = Parser.optional p Dot in + let attrs = parseAttributes p in + match p.Parser.token with + | Tilde -> + Parser.next p; + let (name, loc) = parseLident p in + let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr p in + {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes} + in + begin match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + | _ -> + Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) + end + | Lident _ -> + let (name, loc) = parseLident p in + begin match p.token with + | Colon -> + let () = + let error = Diagnostics.message ( + ErrorMessages.missingTildeLabeledParameter name + ) in + Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error + in + Parser.next p; + let typ = parseTypExpr p in + begin match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) + | _ -> + Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) + end + | _ -> + let constr = Location.mkloc (Longident.Lident name) loc in + let args = parseTypeConstructorArgs ~constrName:constr p in + let typ = Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args + in + + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + let typ = parseTypeAlias p typ in + Some (uncurried, [], Asttypes.Nolabel, typ, startPos) + end + | _ -> + let typ = parseTypExpr p in + let typWithAttributes = {typ with ptyp_attributes = List.concat[attrs; typ.ptyp_attributes]} in + Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) + ) else + None + +(* (int, ~x:string, float) *) +and parseTypeParameters p = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + let unitConstr = Location.mkloc (Longident.Lident "unit") loc in + let typ = Ast_helper.Typ.constr unitConstr [] in + [(false, [], Asttypes.Nolabel, typ, startPos)] + | _ -> + let params = + parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen ~f:parseTypeParameter p + in + Parser.expect Rparen p; + params + +and parseEs6ArrowType ~attrs p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Tilde -> + Parser.next p; + let (name, loc) = parseLident p in + let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = + let typ = parseTypExpr ~alias:false ~es6Arrow:false p in + {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes} + in + let arg = match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Asttypes.Optional name + | _ -> + Asttypes.Labelled name + in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType + | _ -> + let parameters = parseTypeParameters p in + Parser.expect EqualGreater p; + let returnType = parseTypExpr ~alias:false p in + let endPos = p.prevEndPos in + let typ = List.fold_right (fun (uncurried, attrs, argLbl, typ, startPos) t -> + let attrs = if uncurried then uncurryAttr::attrs else attrs in + Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t + ) parameters returnType + in + {typ with + ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; + ptyp_loc = mkLoc startPos p.prevEndPos} + +(* + * typexpr ::= + * | 'ident + * | _ + * | (typexpr) + * | typexpr => typexpr --> es6 arrow + * | (typexpr, typexpr) => typexpr --> es6 arrow + * | /typexpr, typexpr, typexpr/ --> tuple + * | typeconstr + * | typeconstr + * | typeconstr + * | typexpr as 'ident + * | %attr-id --> extension + * | %attr-id(payload) --> extension + * + * typeconstr ::= + * | lident + * | uident.lident + * | uident.uident.lident --> long module path + *) +and parseTypExpr ?attrs ?(es6Arrow=true) ?(alias=true) p = + (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) + let startPos = p.Parser.startPos in + let attrs = match attrs with + | Some attrs -> + attrs + | None -> + parseAttributes p in + let typ = if es6Arrow && isEs6ArrowType p then + parseEs6ArrowType ~attrs p + else + let typ = parseAtomicTypExpr ~attrs p in + parseArrowTypeRest ~es6Arrow ~startPos typ p + in + let typ = if alias then parseTypeAlias p typ else typ in + (* Parser.eatBreadcrumb p; *) + typ + +and parseArrowTypeRest ~es6Arrow ~startPos typ p = + match p.Parser.token with + | (EqualGreater | MinusGreater) as token when es6Arrow == true -> + (* error recovery *) + if token = MinusGreater then ( + Parser.expect EqualGreater p; + ); + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType + | _ -> typ + +and parseTypExprRegion p = + if Grammar.isTypExprStart p.Parser.token then + Some (parseTypExpr p) + else + None + +and parseTupleType ~attrs ~first ~startPos p = + let typexprs = + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + ) + in + Parser.expect Rparen p; + let () = match typexprs with + | [_] -> + Parser.err ~startPos ~endPos:p.prevEndPos p + (Diagnostics.message ErrorMessages.tupleSingleElement) + | _ -> () + in + let tupleLoc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc typexprs + +and parseTypeConstructorArgRegion p = + if Grammar.isTypExprStart p.Parser.token then + Some (parseTypExpr p) + else if p.token = LessThan then ( + Parser.next p; + parseTypeConstructorArgRegion p + ) else + None + +(* Js.Nullable.value<'a> *) +and parseTypeConstructorArgs ~constrName p = + let opening = p.Parser.token in + let openingStartPos = p.startPos in + match opening with + | LessThan | Lparen -> + Scanner.setDiamondMode p.scanner; + Parser.next p; + let typeArgs = + (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:GreaterThan + ~f:parseTypeConstructorArgRegion + p + in + let () = match p.token with + | Rparen when opening = Token.Lparen -> + let typ = Ast_helper.Typ.constr constrName typeArgs in + let msg = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent ( + Doc.concat [ + Doc.line; + ResPrinter.printTypExpr typ CommentTable.empty; + ] + ) + ] + ) |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> + Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + typeArgs + | _ -> [] + +(* string-field-decl ::= + * | string: poly-typexpr + * | attributes string-field-decl *) +and parseStringFieldDeclaration p = + let attrs = parseAttributes p in + match p.Parser.token with + | String name -> + let nameStartPos = p.startPos in + let nameEndPos = p.endPos in + Parser.next p; + let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some(Parsetree.Otag (fieldName, attrs, typ)) + | DotDotDot -> + Parser.next p; + let typ = parseTypExpr p in + Some(Parsetree.Oinherit typ) + | Lident name -> + let nameLoc = mkLoc p.startPos p.endPos in + Parser.err p (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); + Parser.next p; + let fieldName = Location.mkloc name nameLoc in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parsePolyTypeExpr p in + Some(Parsetree.Otag (fieldName, attrs, typ)) + | _token -> + None + +(* field-decl ::= + * | [mutable] field-name : poly-typexpr + * | attributes field-decl *) +and parseFieldDeclaration p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let mut = if Parser.optional p Token.Mutable then + Asttypes.Mutable + else + Asttypes.Immutable + in + let (lident, loc) = match p.token with + | _ -> parseLident p + in + let name = Location.mkloc lident loc in + let typ = match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + in + let loc = mkLoc startPos typ.ptyp_loc.loc_end in + Ast_helper.Type.field ~attrs ~loc ~mut name typ + + +and parseFieldDeclarationRegion p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + let mut = if Parser.optional p Token.Mutable then + Asttypes.Mutable + else + Asttypes.Immutable + in + match p.token with + | Lident _ -> + let (lident, loc) = parseLident p in + let name = Location.mkloc lident loc in + let typ = match p.Parser.token with + | Colon -> + Parser.next p; + parsePolyTypeExpr p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + in + let loc = mkLoc startPos typ.ptyp_loc.loc_end in + Some(Ast_helper.Type.field ~attrs ~loc ~mut name typ) + | _ -> + None + +(* record-decl ::= + * | { field-decl } + * | { field-decl, field-decl } + * | { field-decl, field-decl, field-decl, } + *) +and parseRecordDeclaration p = + Parser.leaveBreadcrumb p Grammar.RecordDecl; + Parser.expect Lbrace p; + let rows = + parseCommaDelimitedRegion + ~grammar:Grammar.RecordDecl + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + rows + +(* constr-args ::= + * | (typexpr) + * | (typexpr, typexpr) + * | (typexpr, typexpr, typexpr,) + * | (record-decl) + * + * TODO: should we overparse inline-records in every position? + * Give a good error message afterwards? + *) +and parseConstrDeclArgs p = + let constrArgs = match p.Parser.token with + | Lparen -> + Parser.next p; + (* TODO: this could use some cleanup/stratification *) + begin match p.Parser.token with + | Lbrace -> + let lbrace = p.startPos in + Parser.next p; + let startPos = p.Parser.startPos in + begin match p.Parser.token with + | DotDot | Dot -> + let closedFlag = match p.token with + | DotDot -> Parser.next p; Asttypes.Open + | Dot -> Parser.next p; Asttypes.Closed + | _ -> Asttypes.Closed + in + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ::moreArgs) + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `User({...a, "u": int})` *) + Parser.next p; + let typ = parseTypExpr p in + let () = match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p; + | _ -> Parser.expect Comma p + in + let () = match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in + let fields = + (Parsetree.Oinherit typ)::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ::moreArgs) + | _ -> + let attrs = parseAttributes p in + begin match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + begin match field with + | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + end + in + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + Parser.optional p Comma |> ignore; + let moreArgs = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ::moreArgs) + | _ -> + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + | attrs -> + let first = + let field = parseFieldDeclaration p in + Parser.expect Comma p; + {field with Parsetree.pld_attributes = attrs} + in + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + ) + in + let () = match fields with + | [] -> Parser.err ~startPos:lbrace p ( + Diagnostics.message "An inline record declaration needs at least one field" + ) + | _ -> () + in + Parser.expect Rbrace p; + Parser.optional p Comma |> ignore; + Parser.expect Rparen p; + Parsetree.Pcstr_record fields + end + end + | _ -> + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple args + end + | _ -> Pcstr_tuple [] + in + let res = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseTypExpr p) + | _ -> None + in + (constrArgs, res) + +(* constr-decl ::= + * | constr-name + * | attrs constr-name + * | constr-name const-args + * | attrs constr-name const-args *) + and parseTypeConstructorDeclarationWithBar p = + match p.Parser.token with + | Bar -> + let startPos = p.Parser.startPos in + Parser.next p; + Some (parseTypeConstructorDeclaration ~startPos p) + | _ -> None + + and parseTypeConstructorDeclaration ~startPos p = + Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration; + let attrs = parseAttributes p in + match p.Parser.token with + | Uident uident -> + let uidentLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let (args, res) = parseConstrDeclArgs p in + Parser.eatBreadcrumb p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.constructor ~loc ~attrs ?res ~args (Location.mkloc uident uidentLoc) + | t -> + Parser.err p (Diagnostics.uident t); + Ast_helper.Type.constructor (Location.mknoloc "_") + + (* [|] constr-decl { | constr-decl } *) + and parseTypeConstructorDeclarations ?first p = + let firstConstrDecl = match first with + | None -> + let startPos = p.Parser.startPos in + ignore (Parser.optional p Token.Bar); + parseTypeConstructorDeclaration ~startPos p + | Some firstConstrDecl -> + firstConstrDecl + in + firstConstrDecl::( + parseRegion + ~grammar:Grammar.ConstructorDeclaration + ~f:parseTypeConstructorDeclarationWithBar + p + ) + +(* + * type-representation ::= + * ∣ = [ | ] constr-decl { | constr-decl } + * ∣ = private [ | ] constr-decl { | constr-decl } + * | = | + * ∣ = private | + * ∣ = record-decl + * ∣ = private record-decl + * | = .. + *) +and parseTypeRepresentation p = + Parser.leaveBreadcrumb p Grammar.TypeRepresentation; + (* = consumed *) + let privateFlag = + if Parser.optional p Token.Private + then Asttypes.Private + else Asttypes.Public + in + let kind = match p.Parser.token with + | Bar | Uident _ -> + Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) + | Lbrace -> + Parsetree.Ptype_record (parseRecordDeclaration p) + | DotDot -> + Parser.next p; + Ptype_open + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + (* TODO: I have no idea if this is even remotely a good idea *) + Parsetree.Ptype_variant [] + in + Parser.eatBreadcrumb p; + (privateFlag, kind) + +(* type-param ::= + * | variance 'lident + * | variance 'uident + * | variance _ + * + * variance ::= + * | + + * | - + * | (* empty *) + *) +and parseTypeParam p = + let variance = match p.Parser.token with + | Plus -> Parser.next p; Asttypes.Covariant + | Minus -> Parser.next p; Contravariant + | _ -> Invariant + in + match p.Parser.token with + | SingleQuote -> + Parser.next p; + let (ident, loc) = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in + Some (Ast_helper.Typ.var ~loc ident, variance) + | Underscore -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Some (Ast_helper.Typ.any ~loc (), variance) + | (Uident _ | Lident _) as token -> + Parser.err p (Diagnostics.message ( + "Type params start with a singlequote: '" ^ (Token.toString token) + )); + let (ident, loc) = + parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in + Some (Ast_helper.Typ.var ~loc ident, variance) + | _token -> + None + +(* type-params ::= + * | + * ∣ + * ∣ + * ∣ + * + * TODO: when we have pretty-printer show an error + * with the actual code corrected. *) +and parseTypeParams ~parent p = + let opening = p.Parser.token in + match opening with + | LessThan | Lparen when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> + Scanner.setDiamondMode p.scanner; + let openingStartPos = p.startPos in + Parser.leaveBreadcrumb p Grammar.TypeParams; + Parser.next p; + let params = + parseCommaDelimitedRegion + ~grammar:Grammar.TypeParams + ~closing:GreaterThan + ~f:parseTypeParam + p + in + let () = match p.token with + | Rparen when opening = Token.Lparen -> + let msg = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.concat [ + ResPrinter.printLongident parent.Location.txt; + ResPrinter.printTypeParams params CommentTable.empty; + ] + ] + ) + ] + ) |> Doc.toString ~width:80 + in + Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); + Parser.next p + | _ -> + Parser.expect GreaterThan p + in + Scanner.popMode p.scanner Diamond; + Parser.eatBreadcrumb p; + params + | _ -> [] + +(* type-constraint ::= constraint ' ident = typexpr *) +and parseTypeConstraint p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Token.Constraint -> + Parser.next p; + Parser.expect SingleQuote p; + begin match p.Parser.token with + | Lident ident -> + let identLoc = mkLoc startPos p.endPos in + Parser.next p; + Parser.expect Equal p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) + | t -> + Parser.err p (Diagnostics.lident t); + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Typ.any (), parseTypExpr p, loc) + end + | _ -> None + +(* type-constraints ::= + * | (* empty *) + * | type-constraint + * | type-constraint type-constraint + * | type-constraint type-constraint type-constraint (* 0 or more *) + *) +and parseTypeConstraints p = + parseRegion + ~grammar:Grammar.TypeConstraint + ~f:parseTypeConstraint + p + +and parseTypeEquationOrConstrDecl p = + let uidentStartPos = p.Parser.startPos in + match p.Parser.token with + | Uident uident -> + Parser.next p; + begin match p.Parser.token with + | Dot -> + Parser.next p; + let typeConstr = + parseValuePathTail p uidentStartPos (Longident.Lident uident) + in + let loc = mkLoc uidentStartPos p.prevEndPos in + let typ = parseTypeAlias p ( + Ast_helper.Typ.constr ~loc typeConstr (parseTypeConstructorArgs ~constrName:typeConstr p) + ) in + begin match p.token with + | Equal -> + Parser.next p; + let (priv, kind) = parseTypeRepresentation p in + (Some typ, priv, kind) + | EqualGreater -> + Parser.next p; + let returnType = parseTypExpr ~alias:false p in + let loc = mkLoc uidentStartPos p.prevEndPos in + let arrowType = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in + let typ = parseTypeAlias p arrowType in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + end + | _ -> + let uidentEndPos = p.prevEndPos in + let (args, res) = parseConstrDeclArgs p in + let first = Some ( + let uidentLoc = mkLoc uidentStartPos uidentEndPos in + Ast_helper.Type.constructor + ~loc:(mkLoc uidentStartPos p.prevEndPos) + ?res + ~args + (Location.mkloc uident uidentLoc) + ) in + (None, Asttypes.Public, Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first)) + end + | t -> + Parser.err p (Diagnostics.uident t); + (* TODO: is this a good idea? *) + (None, Asttypes.Public, Parsetree.Ptype_abstract) + +and parseRecordOrObjectDecl p = + let startPos = p.Parser.startPos in + Parser.expect Lbrace p; + match p.Parser.token with + | DotDot | Dot -> + let closedFlag = match p.token with + | DotDot -> Parser.next p; Asttypes.Open + | Dot -> Parser.next p; Asttypes.Closed + | _ -> Asttypes.Closed + in + let fields = + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag + |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | DotDotDot -> + let dotdotdotStart = p.startPos in + let dotdotdotEnd = p.endPos in + (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) + Parser.next p; + let typ = parseTypExpr p in + let () = match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.sameTypeSpread); + Parser.next p; + | _ -> Parser.expect Comma p + in + let () = match p.token with + | Lident _ -> + Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p + (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) + | _ -> () + in + let fields = + (Parsetree.Oinherit typ)::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> + let attrs = parseAttributes p in + begin match p.Parser.token with + | String _ -> + let closedFlag = Asttypes.Closed in + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + | attrs -> + let first = + Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; + let field = match parseStringFieldDeclaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eatBreadcrumb p; + begin match field with + | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + end + in + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace + ~f:parseStringFieldDeclaration + p + ) + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag |> parseTypeAlias p + in + let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> + Parser.leaveBreadcrumb p Grammar.RecordDecl; + let fields = match attrs with + | [] -> + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + | attr::_ as attrs -> + let first = + let field = parseFieldDeclaration p in + Parser.optional p Comma |> ignore; + {field with + Parsetree.pld_attributes = attrs; + pld_loc = { + field.Parsetree.pld_loc with loc_start = + (attr |> fst).loc.loc_start + } + } + in + first::( + parseCommaDelimitedRegion + ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f:parseFieldDeclarationRegion + p + ) + in + let () = match fields with + | [] -> Parser.err ~startPos p ( + Diagnostics.message "A record needs at least one field" + ) + | _ -> () + in + Parser.expect Rbrace p; + Parser.eatBreadcrumb p; + (None, Asttypes.Public, Parsetree.Ptype_record fields) + end + +and parsePrivateEqOrRepr p = + Parser.expect Private p; + match p.Parser.token with + | Lbrace -> + let (manifest, _ ,kind) = parseRecordOrObjectDecl p in + (manifest, Asttypes.Private, kind) + | Uident _ -> + let (manifest, _, kind) = parseTypeEquationOrConstrDecl p in + (manifest, Asttypes.Private, kind) + | Bar | DotDot -> + let (_, kind) = parseTypeRepresentation p in + (None, Asttypes.Private, kind) + | t when Grammar.isTypExprStart t -> + (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) + | _ -> + let (_, kind) = parseTypeRepresentation p in + (None, Asttypes.Private, kind) + +(* + polymorphic-variant-type ::= + | [ tag-spec-first { | tag-spec } ] + | [> [ tag-spec ] { | tag-spec } ] + | [< [|] tag-spec-full { | tag-spec-full } [ > { `tag-name }+ ] ] + + tag-spec-first ::= `tag-name [ of typexpr ] + | [ typexpr ] | tag-spec + + tag-spec ::= `tag-name [ of typexpr ] + | typexpr + + tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ] + | typexpr +*) +and parsePolymorphicVariantType ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Lbracket p; + match p.token with + | GreaterThan -> + Parser.next p; + let rowFields = + begin match p.token with + | Rbracket -> + [] + | Bar -> + parseTagSpecs p + | _ -> + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p + end + in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc rowFields Open None in + Parser.expect Rbracket p; + variant + | LessThan -> + Parser.next p; + Parser.optional p Bar |> ignore; + let rowField = parseTagSpecFull p in + let rowFields = parseTagSpecFulls p in + let tagNames = + if p.token == GreaterThan + then begin + Parser.next p; + let rec loop p = match p.Parser.token with + | Rbracket -> [] + | _ -> + let (ident, _loc) = parseHashIdent ~startPos:p.startPos p in + ident :: loop p + in + loop p + end + else [] in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed (Some tagNames) in + Parser.expect Rbracket p; + variant + | _ -> + let rowFields1 = parseTagSpecFirst p in + let rowFields2 = parseTagSpecs p in + let variant = + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None in + Parser.expect Rbracket p; + variant + +and parseTagSpecFulls p = + match p.Parser.token with + | Rbracket -> + [] + | GreaterThan -> + [] + | Bar -> + Parser.next p; + let rowField = parseTagSpecFull p in + rowField ::parseTagSpecFulls p + | _ -> + [] + +and parseTagSpecFull p = + let attrs = parseAttributes p in + match p.Parser.token with + | Hash -> + parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p + | _ -> + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ + +and parseTagSpecs p = + match p.Parser.token with + | Bar -> + Parser.next p; + let rowField = parseTagSpec p in + rowField :: parseTagSpecs p + | _ -> + [] + +and parseTagSpec p = + let attrs = parseAttributes p in + match p.Parser.token with + | Hash -> + parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p + | _ -> + let typ = parseTypExpr ~attrs p in + Parsetree.Rinherit typ + +and parseTagSpecFirst p = + let attrs = parseAttributes p in + match p.Parser.token with + | Bar -> + Parser.next p; + [parseTagSpec p] + | Hash -> + [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] + | _ -> + let typ = parseTypExpr ~attrs p in + begin match p.token with + | Rbracket -> + (* example: [ListStyleType.t] *) + [Parsetree.Rinherit typ;] + | _ -> + Parser.expect Bar p; + [Parsetree.Rinherit typ; parseTagSpec p] + end + +and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = + let startPos = p.Parser.startPos in + let (ident, loc) = parseHashIdent ~startPos p in + let rec loop p = + match p.Parser.token with + | Band when full -> + Parser.next p; + let rowField = parsePolymorphicVariantTypeArgs p in + rowField :: loop p + | _ -> + [] + in + let firstTuple, tagContainsAConstantEmptyConstructor = + match p.Parser.token with + | Band when full -> + Parser.next p; + [parsePolymorphicVariantTypeArgs p], true + | Lparen -> + [parsePolymorphicVariantTypeArgs p], false + | _ -> + [], true + in + let tuples = firstTuple @ loop p in + Parsetree.Rtag ( + Location.mkloc ident loc, + attrs, + tagContainsAConstantEmptyConstructor, + tuples + ) + +and parsePolymorphicVariantTypeArgs p = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + let args = parseCommaDelimitedRegion + ~grammar:Grammar.TypExprList + ~closing:Rparen + ~f:parseTypExprRegion + p + in + Parser.expect Rparen p; + let attrs = [] in + let loc = mkLoc startPos p.prevEndPos in + match args with + | [{ptyp_desc = Ptyp_tuple _} as typ] as types -> + if p.mode = ParseForTypeChecker then + typ + else + Ast_helper.Typ.tuple ~loc ~attrs types + | [typ] -> typ + | types -> Ast_helper.Typ.tuple ~loc ~attrs types + +and parseTypeEquationAndRepresentation p = + match p.Parser.token with + | Equal | Bar as token -> + if token = Bar then Parser.expect Equal p; + Parser.next p; + begin match p.Parser.token with + | Uident _ -> + parseTypeEquationOrConstrDecl p + | Lbrace -> + parseRecordOrObjectDecl p + | Private -> + parsePrivateEqOrRepr p + | Bar | DotDot -> + let (priv, kind) = parseTypeRepresentation p in + (None, priv, kind) + | _ -> + let manifest = Some (parseTypExpr p) in + begin match p.Parser.token with + | Equal -> + Parser.next p; + let (priv, kind) = parseTypeRepresentation p in + (manifest, priv, kind) + | _ -> + (manifest, Public, Parsetree.Ptype_abstract) + end + end + | _ -> (None, Public, Parsetree.Ptype_abstract) + +(* type-definition ::= type [rec] typedef { and typedef } + * typedef ::= typeconstr-name [type-params] type-information + * type-information ::= [type-equation] [type-representation] { type-constraint } + * type-equation ::= = typexpr *) +and parseTypeDef ~attrs ~startPos p = + Parser.leaveBreadcrumb p Grammar.TypeDef; + (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *) + Parser.leaveBreadcrumb p Grammar.TypeConstrName; + let (name, loc) = parseLident p in + let typeConstrName = Location.mkloc name loc in + Parser.eatBreadcrumb p; + let params = + let constrName = Location.mkloc (Longident.Lident name) loc in + parseTypeParams ~parent:constrName p in + let typeDef = + let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in + let cstrs = parseTypeConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.mk + ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest typeConstrName + in + Parser.eatBreadcrumb p; + typeDef + +and parseTypeExtension ~params ~attrs ~name p = + Parser.expect PlusEqual p; + let priv = + if Parser.optional p Token.Private + then Asttypes.Private + else Asttypes.Public + in + let constrStart = p.Parser.startPos in + Parser.optional p Bar |> ignore; + let first = + let (attrs, name, kind) = match p.Parser.token with + | Bar -> + Parser.next p; + parseConstrDef ~parseAttrs:true p + | _ -> + parseConstrDef ~parseAttrs:true p + in + let loc = mkLoc constrStart p.prevEndPos in + Ast_helper.Te.constructor ~loc ~attrs name kind + in + let rec loop p cs = + match p.Parser.token with + | Bar -> + let startPos = p.Parser.startPos in + Parser.next p; + let (attrs, name, kind) = parseConstrDef ~parseAttrs:true p in + let extConstr = + Ast_helper.Te.constructor ~attrs ~loc:(mkLoc startPos p.prevEndPos) name kind + in + loop p (extConstr::cs) + | _ -> + List.rev cs + in + let constructors = loop p [first] in + Ast_helper.Te.mk ~attrs ~params ~priv name constructors + +and parseTypeDefinitions ~attrs ~name ~params ~startPos p = + let typeDef = + let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in + let cstrs = parseTypeConstraints p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Type.mk + ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest + {name with txt = lidentOfPath name.Location.txt} + in + let rec loop p defs = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + Parser.next p; + let attrs = match p.token with + | Export -> + let exportLoc = mkLoc p.startPos p.endPos in + Parser.next p; + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + genTypeAttr::attrs + | _ -> attrs + in + let typeDef = parseTypeDef ~attrs ~startPos p in + loop p (typeDef::defs) + | _ -> + List.rev defs + in + loop p [typeDef] + +(* TODO: decide if we really want type extensions (eg. type x += Blue) + * It adds quite a bit of complexity that can be avoided, + * implemented for now. Needed to get a feel for the complexities of + * this territory of the grammar *) +and parseTypeDefinitionOrExtension ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Token.Typ p; + let recFlag = match p.token with + | Rec -> Parser.next p; Asttypes.Recursive + | Lident "nonrec" -> + Parser.next p; + Asttypes.Nonrecursive + | _ -> Asttypes.Nonrecursive + in + let name = parseValuePath p in + let params = parseTypeParams ~parent:name p in + match p.Parser.token with + | PlusEqual -> + TypeExt(parseTypeExtension ~params ~attrs ~name p) + | _ -> + (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) + let () = match name.Location.txt with + | Lident _ -> () + | longident -> + Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p + (longident |> ErrorMessages.typeDeclarationNameLongident |> Diagnostics.message) + in + let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in + TypeDef {recFlag; types = typeDefs} + +(* external value-name : typexp = external-declaration *) +and parseExternalDef ~attrs ~startPos p = + Parser.leaveBreadcrumb p Grammar.External; + Parser.expect Token.External p; + let (name, loc) = parseLident p in + let name = Location.mkloc name loc in + Parser.expect ~grammar:(Grammar.TypeExpression) Colon p; + let typExpr = parseTypExpr p in + let equalStart = p.startPos in + let equalEnd = p.endPos in + Parser.expect Equal p; + let prim = match p.token with + | String s -> Parser.next p; [s] + | _ -> + Parser.err ~startPos:equalStart ~endPos:equalEnd p + (Diagnostics.message + ("An external requires the name of the JS value you're referring to, like \"" + ^ name.txt ^ "\".")); + [] + in + let loc = mkLoc startPos p.prevEndPos in + let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in + Parser.eatBreadcrumb p; + vb + +(* constr-def ::= + * | constr-decl + * | constr-name = constr + * + * constr-decl ::= constr-name constr-args + * constr-name ::= uident + * constr ::= path-uident *) +and parseConstrDef ~parseAttrs p = + let attrs = if parseAttrs then parseAttributes p else [] in + let name = match p.Parser.token with + | Uident name -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc name loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let kind = match p.Parser.token with + | Lparen -> + let (args, res) = parseConstrDeclArgs p in + Parsetree.Pext_decl (args, res) + | Equal -> + Parser.next p; + let longident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pext_rebind longident + | Colon -> + Parser.next p; + let typ = parseTypExpr p in + Parsetree.Pext_decl (Pcstr_tuple [], Some typ) + | _ -> + Parsetree.Pext_decl (Pcstr_tuple [], None) + in + (attrs, name, kind) + +(* + * exception-definition ::= + * | exception constr-decl + * ∣ exception constr-name = constr + * + * constr-name ::= uident + * constr ::= long_uident *) +and parseExceptionDef ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Token.Exception p; + let (_, name, kind) = parseConstrDef ~parseAttrs:false p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Te.constructor ~loc ~attrs name kind + +(* module structure on the file level *) +and parseImplementation p : Parsetree.structure = + parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion + [@@progress (Parser.next, Parser.expect, Parser.checkProgress)] + +and parseNewlineOrSemicolonStructure p = + match p.Parser.token with + | Semicolon -> + Parser.next p + | token when Grammar.isStructureItemStart token -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err + ~startPos:p.prevEndPos + ~endPos: p.endPos + p + (Diagnostics.message "consecutive statements on a line must be separated by ';' or a newline") + | _ -> () + +and parseStructureItemRegion p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Open -> + let openDescription = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.open_ ~loc openDescription) + | Let -> + let (recFlag, letBindings) = parseLetBindings ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.value ~loc recFlag letBindings) + | Typ -> + Parser.beginRegion p; + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_ ~loc recFlag types) + | TypeExt(ext) -> + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Str.type_extension ~loc ext) + end + | External -> + let externalDef = parseExternalDef ~attrs ~startPos p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.primitive ~loc externalDef) + | Import -> + let importDescr = parseJsImport ~startPos ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + let structureItem = JsFfi.toParsetree importDescr in + Some {structureItem with pstr_loc = loc} + | Exception -> + let exceptionDef = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.exception_ ~loc exceptionDef) + | Include -> + let includeStatement = parseIncludeStatement ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.include_ ~loc includeStatement) + | Export -> + let structureItem = parseJsExport ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some {structureItem with pstr_loc = loc} + | Module -> + Parser.beginRegion p; + let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some {structureItem with pstr_loc = loc} + | AtAt -> + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.attribute ~loc attr) + | PercentPercent -> + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Str.extension ~attrs ~loc extension) + | token when Grammar.isExprStart token -> + let prevEndPos = p.Parser.endPos in + let exp = parseExpr p in + parseNewlineOrSemicolonStructure p; + let loc = mkLoc startPos p.prevEndPos in + Parser.checkProgress ~prevEndPos ~result:(Ast_helper.Str.eval ~loc ~attrs exp) p + | _ -> + begin match attrs with + | (({Asttypes.loc = attrLoc}, _) as attr)::_ -> + Parser.err + ~startPos:attrLoc.loc_start + ~endPos:attrLoc.loc_end + p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + let expr = parseExpr p in + Some (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) + | _ -> + None + end + +and parseJsImport ~startPos ~attrs p = + Parser.expect Token.Import p; + let importSpec = match p.Parser.token with + | Token.Lident _ | Token.At -> + let decl = match parseJsFfiDeclaration p with + | Some decl -> decl + | None -> assert false + in + JsFfi.Default decl + | _ -> JsFfi.Spec(parseJsFfiDeclarations p) + in + let scope = parseJsFfiScope p in + let loc = mkLoc startPos p.prevEndPos in + JsFfi.importDescr ~attrs ~importSpec ~scope ~loc + +and parseJsExport ~attrs p = + let exportStart = p.Parser.startPos in + Parser.expect Token.Export p; + let exportLoc = mkLoc exportStart p.prevEndPos in + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + let attrs = genTypeAttr::attrs in + match p.Parser.token with + | Typ -> + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + Ast_helper.Str.type_ recFlag types + | TypeExt(ext) -> + Ast_helper.Str.type_extension ext + end + | (* Let *) _ -> + let (recFlag, letBindings) = parseLetBindings ~attrs p in + Ast_helper.Str.value recFlag letBindings + +and parseSignJsExport ~attrs p = + let exportStart = p.Parser.startPos in + Parser.expect Token.Export p; + let exportLoc = mkLoc exportStart p.prevEndPos in + let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in + let attrs = genTypeAttr::attrs in + match p.Parser.token with + | Typ -> + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + let loc = mkLoc exportStart p.prevEndPos in + Ast_helper.Sig.type_ recFlag types ~loc + | TypeExt(ext) -> + let loc = mkLoc exportStart p.prevEndPos in + Ast_helper.Sig.type_extension ext ~loc + end + | (* Let *) _ -> + let valueDesc = parseSignLetDesc ~attrs p in + let loc = mkLoc exportStart p.prevEndPos in + Ast_helper.Sig.value valueDesc ~loc + +and parseJsFfiScope p = + match p.Parser.token with + | Token.Lident "from" -> + Parser.next p; + begin match p.token with + | String s -> Parser.next p; JsFfi.Module s + | Uident _ | Lident _ -> + let value = parseIdentPath p in + JsFfi.Scope value + | _ -> JsFfi.Global + end + | _ -> JsFfi.Global + +and parseJsFfiDeclarations p = + Parser.expect Token.Lbrace p; + let decls = parseCommaDelimitedRegion + ~grammar:Grammar.JsFfiImport + ~closing:Rbrace + ~f:parseJsFfiDeclaration + p + in + Parser.expect Rbrace p; + decls + +and parseJsFfiDeclaration p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Lident _ -> + let (ident, _) = parseLident p in + let alias = match p.token with + | As -> + Parser.next p; + let (ident, _) = parseLident p in + ident + | _ -> + ident + in + Parser.expect Token.Colon p; + let typ = parseTypExpr p in + let loc = mkLoc startPos p.prevEndPos in + Some (JsFfi.decl ~loc ~alias ~attrs ~name:ident ~typ) + | _ -> None + +(* include-statement ::= include module-expr *) +and parseIncludeStatement ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Token.Include p; + let modExpr = parseModuleExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Incl.mk ~loc ~attrs modExpr + +and parseAtomicModuleExpr p = + let startPos = p.Parser.startPos in + match p.Parser.token with + | Uident _ident -> + let longident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mod.ident ~loc:longident.loc longident + | Lbrace -> + Parser.next p; + let structure = Ast_helper.Mod.structure ( + parseDelimitedRegion + ~grammar:Grammar.Structure + ~closing:Rbrace + ~f:parseStructureItemRegion + p + ) in + Parser.expect Rbrace p; + let endPos = p.prevEndPos in + {structure with pmod_loc = mkLoc startPos endPos} + | Lparen -> + Parser.next p; + let modExpr = match p.token with + | Rparen -> + Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] + | _ -> + parseConstrainedModExpr p + in + Parser.expect Rparen p; + modExpr + | Lident "unpack" -> (* TODO: should this be made a keyword?? *) + Parser.next p; + Parser.expect Lparen p; + let expr = parseExpr p in + begin match p.Parser.token with + | Colon -> + let colonStart = p.Parser.startPos in + Parser.next p; + let attrs = parseAttributes p in + let packageType = parsePackageType ~startPos:colonStart ~attrs p in + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + let constraintExpr = Ast_helper.Exp.constraint_ + ~loc + expr packageType + in + Ast_helper.Mod.unpack ~loc constraintExpr + | _ -> + Parser.expect Rparen p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.unpack ~loc expr + end + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mod.extension ~loc extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleExpr() + +and parsePrimaryModExpr p = + let startPos = p.Parser.startPos in + let modExpr = parseAtomicModuleExpr p in + let rec loop p modExpr = + match p.Parser.token with + | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> + loop p (parseModuleApplication p modExpr) + | _ -> modExpr + in + let modExpr = loop p modExpr in + {modExpr with pmod_loc = mkLoc startPos p.prevEndPos} + +(* + * functor-arg ::= + * | uident : modtype + * | _ : modtype + * | modtype --> "punning" for _ : modtype + * | attributes functor-arg + *) +and parseFunctorArg p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Uident ident -> + Parser.next p; + let uidentEndPos = p.prevEndPos in + begin match p.Parser.token with + | Colon -> + Parser.next p; + let moduleType = parseModuleType p in + let loc = mkLoc startPos uidentEndPos in + let argName = Location.mkloc ident loc in + Some (attrs, argName, Some moduleType, startPos) + | Dot -> + Parser.next p; + let moduleType = + let moduleLongIdent = + parseModuleLongIdentTail ~lowercase:false p startPos (Longident.Lident ident) in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos) + | _ -> + let loc = mkLoc startPos uidentEndPos in + let modIdent = Location.mkloc (Longident.Lident ident) loc in + let moduleType = Ast_helper.Mty.ident ~loc modIdent in + let argName = Location.mknoloc "_" in + Some (attrs, argName, Some moduleType, startPos) + end + | Underscore -> + Parser.next p; + let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in + Parser.expect Colon p; + let moduleType = parseModuleType p in + Some (attrs, argName, Some moduleType, startPos) + | Lparen -> + Parser.next p; + Parser.expect Rparen p; + let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in + Some (attrs, argName, None, startPos) + | _ -> + None + +and parseFunctorArgs p = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.FunctorArgs + ~closing:Rparen + ~f:parseFunctorArg + p + in + Parser.expect Rparen p; + match args with + | [] -> + [[], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos] + | args -> args + +and parseFunctorModuleExpr p = + let startPos = p.Parser.startPos in + let args = parseFunctorArgs p in + let returnType = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseModuleType ~es6Arrow:false p) + | _ -> None + in + Parser.expect EqualGreater p; + let rhsModuleExpr = + let modExpr = parseModuleExpr p in + match returnType with + | Some modType -> + Ast_helper.Mod.constraint_ + ~loc:(mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) + modExpr modType + | None -> modExpr + in + let endPos = p.prevEndPos in + let modExpr = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> + Ast_helper.Mod.functor_ + ~loc:(mkLoc startPos endPos) + ~attrs + name moduleType acc + ) args rhsModuleExpr + in + {modExpr with pmod_loc = mkLoc startPos endPos} + +(* module-expr ::= + * | module-path + * ∣ { structure-items } + * ∣ functorArgs => module-expr + * ∣ module-expr(module-expr) + * ∣ ( module-expr ) + * ∣ ( module-expr : module-type ) + * | extension + * | attributes module-expr *) +and parseModuleExpr p = + let attrs = parseAttributes p in + let modExpr = if isEs6ArrowFunctor p then + parseFunctorModuleExpr p + else + parsePrimaryModExpr p + in + {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} + +and parseConstrainedModExpr p = + let modExpr = parseModuleExpr p in + match p.Parser.token with + | Colon -> + Parser.next p; + let modType = parseModuleType p in + let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in + Ast_helper.Mod.constraint_ ~loc modExpr modType + | _ -> modExpr + +and parseConstrainedModExprRegion p = + if Grammar.isModExprStart p.Parser.token then + Some (parseConstrainedModExpr p) + else + None + +and parseModuleApplication p modExpr = + let startPos = p.Parser.startPos in + Parser.expect Lparen p; + let args = + parseCommaDelimitedRegion + ~grammar:Grammar.ModExprList + ~closing:Rparen + ~f:parseConstrainedModExprRegion + p + in + Parser.expect Rparen p; + let args = match args with + | [] -> + let loc = mkLoc startPos p.prevEndPos in + [Ast_helper.Mod.structure ~loc []] + | args -> args + in + List.fold_left (fun modExpr arg -> + Ast_helper.Mod.apply + ~loc:(mkLoc modExpr.Parsetree.pmod_loc.loc_start arg.Parsetree.pmod_loc.loc_end) + modExpr arg + ) modExpr args + +and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = + let startPos = p.Parser.startPos in + Parser.expect Module p; + match p.Parser.token with + | Typ -> parseModuleTypeImpl ~attrs startPos p + | Lparen -> + let expr = parseFirstClassModuleExpr ~startPos p in + let a = parsePrimaryExpr ~operand:expr p in + let expr = parseBinaryExpr ~a p 1 in + let expr = parseTernaryExpr expr p in + Ast_helper.Str.eval ~attrs expr + | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p + +and parseModuleTypeImpl ~attrs startPos p = + Parser.expect Typ p; + let nameStart = p.Parser.startPos in + let name = match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc + | Uident ident -> + Parser.next p; + let loc = mkLoc nameStart p.prevEndPos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + Parser.expect Equal p; + let moduleType = parseModuleType p in + let moduleTypeDeclaration = + Ast_helper.Mtd.mk + ~attrs + ~loc:(mkLoc nameStart p.prevEndPos) + ~typ:moduleType + name + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Str.modtype ~loc moduleTypeDeclaration + +(* definition ::= + ∣ module rec module-name : module-type = module-expr { and module-name + : module-type = module-expr } *) +and parseMaybeRecModuleBinding ~attrs ~startPos p = + match p.Parser.token with + | Token.Rec -> + Parser.next p; + Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) + | _ -> + Ast_helper.Str.module_ (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) + +and parseModuleBinding ~attrs ~startPos p = + let name = match p.Parser.token with + | Uident ident -> + let startPos = p.Parser.startPos in + Parser.next p; + let loc = mkLoc startPos p.prevEndPos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parseModuleBindingBody p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mb.mk ~attrs ~loc name body + +and parseModuleBindingBody p = + (* TODO: make required with good error message when rec module binding *) + let returnModType = match p.Parser.token with + | Colon -> + Parser.next p; + Some (parseModuleType p) + | _ -> None + in + Parser.expect Equal p; + let modExpr = parseModuleExpr p in + match returnModType with + | Some modType -> + Ast_helper.Mod.constraint_ + ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) + modExpr modType + | None -> modExpr + + +(* module-name : module-type = module-expr + * { and module-name : module-type = module-expr } *) +and parseModuleBindings ~attrs ~startPos p = + let rec loop p acc = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + Parser.next p; + ignore(Parser.optional p Module); (* over-parse for fault-tolerance *) + let modBinding = parseModuleBinding ~attrs ~startPos p in + loop p (modBinding::acc) + | _ -> List.rev acc + in + let first = parseModuleBinding ~attrs ~startPos p in + loop p [first] + +and parseAtomicModuleType p = + let startPos = p.Parser.startPos in + let moduleType = match p.Parser.token with + | Uident _ | Lident _ -> + (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } + * lets go with uppercase terminal for now *) + let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in + Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent + | Lparen -> + Parser.next p; + let mty = parseModuleType p in + Parser.expect Rparen p; + {mty with pmty_loc = mkLoc startPos p.prevEndPos} + | Lbrace -> + Parser.next p; + let spec = + parseDelimitedRegion + ~grammar:Grammar.Signature + ~closing:Rbrace + ~f:parseSignatureItemRegion + p + in + Parser.expect Rbrace p; + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.signature ~loc spec + | Module -> (* TODO: check if this is still atomic when implementing first class modules*) + parseModuleTypeOf p + | Percent -> + let extension = parseExtension p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Mty.extension ~loc extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType() + in + let moduleTypeLoc = mkLoc startPos p.prevEndPos in + {moduleType with pmty_loc = moduleTypeLoc} + +and parseFunctorModuleType p = + let startPos = p.Parser.startPos in + let args = parseFunctorArgs p in + Parser.expect EqualGreater p; + let rhs = parseModuleType p in + let endPos = p.prevEndPos in + let modType = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> + Ast_helper.Mty.functor_ + ~loc:(mkLoc startPos endPos) + ~attrs + name moduleType acc + ) args rhs + in + {modType with pmty_loc = mkLoc startPos endPos} + +(* Module types are the module-level equivalent of type expressions: they + * specify the general shape and type properties of modules. + * + * module-type ::= + * | modtype-path + * | { signature } + * | ( module-type ) --> parenthesized module-type + * | functor-args => module-type --> functor + * | module-type => module-type --> functor + * | module type of module-expr + * | attributes module-type + * | module-type with-mod-constraints + * | extension + *) + and parseModuleType ?(es6Arrow=true) ?(with_=true) p = + let attrs = parseAttributes p in + let modty = if es6Arrow && isEs6ArrowFunctor p then + parseFunctorModuleType p + else + let modty = parseAtomicModuleType p in + match p.Parser.token with + | EqualGreater when es6Arrow == true -> + Parser.next p; + let rhs = parseModuleType ~with_:false p in + let str = Location.mknoloc "_" in + let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.functor_ ~loc str (Some modty) rhs + | _ -> modty + in + let moduleType = { modty with + pmty_attributes = List.concat [modty.pmty_attributes; attrs] + } in + if with_ then + parseWithConstraints moduleType p + else moduleType + + +and parseWithConstraints moduleType p = + match p.Parser.token with + | Lident "with" -> + Parser.next p; + let first = parseWithConstraint p in + let rec loop p acc = + match p.Parser.token with + | And -> + Parser.next p; + loop p ((parseWithConstraint p)::acc) + | _ -> + List.rev acc + in + let constraints = loop p [first] in + let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in + Ast_helper.Mty.with_ ~loc moduleType constraints + | _ -> + moduleType + +(* mod-constraint ::= + * | type typeconstr type-equation type-constraints? + * ∣ type typeconstr-name := typexpr + * ∣ module module-path = extended-module-path + * ∣ module module-path := extended-module-path + * + * TODO: split this up into multiple functions, better errors *) +and parseWithConstraint p = + match p.Parser.token with + | Module -> + Parser.next p; + let modulePath = parseModuleLongIdent ~lowercase:false p in + begin match p.Parser.token with + | ColonEqual -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident) + | Equal -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_module (modulePath, lident) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = parseModuleLongIdent ~lowercase:false p in + Parsetree.Pwith_modsubst (modulePath, lident) + end + | Typ -> + Parser.next p; + let typeConstr = parseValuePath p in + let params = parseTypeParams ~parent:typeConstr p in + begin match p.Parser.token with + | ColonEqual -> + Parser.next p; + let typExpr = parseTypExpr p in + Parsetree.Pwith_typesubst ( + typeConstr, + Ast_helper.Type.mk + ~loc:typeConstr.loc + ~params + ~manifest:typExpr + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | Equal -> + Parser.next p; + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type ( + typeConstr, + Ast_helper.Type.mk + ~loc:typeConstr.loc + ~params + ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let typExpr = parseTypExpr p in + let typeConstraints = parseTypeConstraints p in + Parsetree.Pwith_type ( + typeConstr, + Ast_helper.Type.mk + ~loc:typeConstr.loc + ~params + ~manifest:typExpr + ~cstrs:typeConstraints + (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) + ) + end + | token -> + (* TODO: implement recovery strategy *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Parsetree.Pwith_type ( + (Location.mknoloc (Longident.Lident "")), + Ast_helper.Type.mk + ~params:[] + ~manifest:(Recover.defaultType ()) + ~cstrs:[] + (Location.mknoloc "") + ) + +and parseModuleTypeOf p = + let startPos = p.Parser.startPos in + Parser.expect Module p; + Parser.expect Typ p; + Parser.expect Of p; + let moduleExpr = parseModuleExpr p in + Ast_helper.Mty.typeof_ ~loc:(mkLoc startPos p.prevEndPos) moduleExpr + +(* module signature on the file level *) +and parseSpecification p = + parseRegion ~grammar:Grammar.Specification ~f:parseSignatureItemRegion p + [@@progress (Parser.next, Parser.expect, Parser.checkProgress)] + +and parseNewlineOrSemicolonSignature p = + match p.Parser.token with + | Semicolon -> + Parser.next p + | token when Grammar.isSignatureItemStart token -> + if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () + else + Parser.err + ~startPos:p.prevEndPos + ~endPos: p.endPos + p + (Diagnostics.message "consecutive specifications on a line must be separated by ';' or a newline") + | _ -> () + +and parseSignatureItemRegion p = + let startPos = p.Parser.startPos in + let attrs = parseAttributes p in + match p.Parser.token with + | Let -> + Parser.beginRegion p; + let valueDesc = parseSignLetDesc ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.value ~loc valueDesc) + | Typ -> + Parser.beginRegion p; + begin match parseTypeDefinitionOrExtension ~attrs p with + | TypeDef {recFlag; types} -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_ ~loc recFlag types) + | TypeExt(ext) -> + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.type_extension ~loc ext) + end + | External -> + let externalDef = parseExternalDef ~attrs ~startPos p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.value ~loc externalDef) + | Export -> + let signatureItem = parseSignJsExport ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some {signatureItem with psig_loc = loc} + | Exception -> + let exceptionDef = parseExceptionDef ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.exception_ ~loc exceptionDef) + | Open -> + let openDescription = parseOpenDescription ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.open_ ~loc openDescription) + | Include -> + Parser.next p; + let moduleType = parseModuleType p in + let includeDescription = Ast_helper.Incl.mk + ~loc:(mkLoc startPos p.prevEndPos) + ~attrs + moduleType + in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.include_ ~loc includeDescription) + | Module -> + Parser.beginRegion p; + Parser.next p; + begin match p.Parser.token with + | Uident _ -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl) + | Rec -> + let recModule = parseRecModuleSpec ~attrs ~startPos p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.rec_module ~loc recModule) + | Typ -> + let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in + Parser.endRegion p; + Some modTypeDecl + | _t -> + let modDecl = parseModuleDeclarationOrAlias ~attrs p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Parser.endRegion p; + Some (Ast_helper.Sig.module_ ~loc modDecl) + end + | AtAt -> + let attr = parseStandaloneAttribute p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.attribute ~loc attr) + | PercentPercent -> + let extension = parseExtension ~moduleLanguage:true p in + parseNewlineOrSemicolonSignature p; + let loc = mkLoc startPos p.prevEndPos in + Some (Ast_helper.Sig.extension ~attrs ~loc extension) + | Import -> + Parser.next p; + parseSignatureItemRegion p + | _ -> + begin match attrs with + | (({Asttypes.loc = attrLoc}, _) as attr)::_ -> + Parser.err + ~startPos:attrLoc.loc_start + ~endPos:attrLoc.loc_end + p + (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); + Some Recover.defaultSignatureItem + | _ -> + None + end + +(* module rec module-name : module-type { and module-name: module-type } *) +and parseRecModuleSpec ~attrs ~startPos p = + Parser.expect Rec p; + let rec loop p spec = + let startPos = p.Parser.startPos in + let attrs = parseAttributesAndBinding p in + match p.Parser.token with + | And -> + (* TODO: give a good error message when with constraint, no parens + * and ASet: (Set.S with type elt = A.t) + * and BTree: (Btree.S with type elt = A.t) + * Without parens, the `and` signals the start of another + * `with-constraint` + *) + Parser.expect And p; + let decl = parseRecModuleDeclaration ~attrs ~startPos p in + loop p (decl::spec) + | _ -> + List.rev spec + in + let first = parseRecModuleDeclaration ~attrs ~startPos p in + loop p [first] + +(* module-name : module-type *) +and parseRecModuleDeclaration ~attrs ~startPos p = + let name = match p.Parser.token with + | Uident modName -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc modName loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + Parser.expect Colon p; + let modType = parseModuleType p in + Ast_helper.Md.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs name modType + +and parseModuleDeclarationOrAlias ~attrs p = + let startPos = p.Parser.startPos in + let moduleName = match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.Parser.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = match p.Parser.token with + | Colon -> + Parser.next p; + parseModuleType p + | Equal -> + Parser.next p; + let lident = parseModuleLongIdent ~lowercase:false p in + Ast_helper.Mty.alias lident + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.defaultModuleType() + in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Md.mk ~loc ~attrs moduleName body + +and parseModuleTypeDeclaration ~attrs ~startPos p = + Parser.expect Typ p; + let moduleName = match p.Parser.token with + | Uident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | Lident ident -> + let loc = mkLoc p.startPos p.endPos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let typ = match p.Parser.token with + | Equal -> + Parser.next p; + Some (parseModuleType p) + | _ -> None + in + let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in + Ast_helper.Sig.modtype ~loc:(mkLoc startPos p.prevEndPos) moduleDecl + +and parseSignLetDesc ~attrs p = + let startPos = p.Parser.startPos in + Parser.optional p Let |> ignore; + let (name, loc) = parseLident p in + let name = Location.mkloc name loc in + Parser.expect Colon p; + let typExpr = parsePolyTypeExpr p in + let loc = mkLoc startPos p.prevEndPos in + Ast_helper.Val.mk ~loc ~attrs name typExpr + +(* attr-id ::= lowercase-ident +∣ capitalized-ident +∣ attr-id . attr-id *) +and parseAttributeId ~startPos p = + let rec loop p acc = + match p.Parser.token with + | Lident ident | Uident ident -> + Parser.next p; + let id = acc ^ ident in + begin match p.Parser.token with + | Dot -> Parser.next p; loop p (id ^ ".") + | _ -> id + end + | token when Token.isKeyword token -> + Parser.next p; + let id = acc ^ (Token.toString token) in + begin match p.Parser.token with + | Dot -> Parser.next p; loop p (id ^ ".") + | _ -> id + end + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + acc + in + let id = loop p "" in + let endPos = p.prevEndPos in + Location.mkloc id (mkLoc startPos endPos) + +(* + * payload ::= empty + * | ( structure-item ) + * + * TODO: what about multiple structure items? + * @attr({let x = 1; let x = 2}) + * + * Also what about type-expressions and specifications? + * @attr(:myType) ??? + *) +and parsePayload p = + match p.Parser.token with + | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> + Parser.leaveBreadcrumb p Grammar.AttributePayload; + Parser.next p; + begin match p.token with + | Colon -> + Parser.next p; + let payload = if Grammar.isSignatureItemStart p.token then + Parsetree.PSig ( + parseDelimitedRegion + ~grammar:Grammar.Signature + ~closing:Rparen + ~f:parseSignatureItemRegion + p + ) + else + Parsetree.PTyp (parseTypExpr p) + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + payload + | Question -> + Parser.next p; + let pattern = parsePattern p in + let expr = match p.token with + | When | If -> + Parser.next p; + Some (parseExpr p) + | _ -> + None + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PPat (pattern, expr) + | _ -> + let items = parseDelimitedRegion + ~grammar:Grammar.Structure + ~closing:Rparen + ~f:parseStructureItemRegion + p + in + Parser.expect Rparen p; + Parser.eatBreadcrumb p; + Parsetree.PStr items + end + | _ -> Parsetree.PStr [] + +(* type attribute = string loc * payload *) +and parseAttribute p = + match p.Parser.token with + | At -> + let startPos = p.startPos in + Parser.next p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + Some(attrId, payload) + | _ -> None + +and parseAttributes p = + parseRegion p + ~grammar:Grammar.Attribute + ~f:parseAttribute + +(* + * standalone-attribute ::= + * | @@ atribute-id + * | @@ attribute-id ( structure-item ) + *) +and parseStandaloneAttribute p = + let startPos = p.startPos in + Parser.expect AtAt p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + (attrId, payload) + +(* extension ::= % attr-id attr-payload + * | %% attr-id( + * expr ::= ... + * ∣ extension + * + * typexpr ::= ... + * ∣ extension + * + * pattern ::= ... + * ∣ extension + * + * module-expr ::= ... + * ∣ extension + * + * module-type ::= ... + * ∣ extension + * + * class-expr ::= ... + * ∣ extension + * + * class-type ::= ... + * ∣ extension + * + * + * item extension nodes usable in structures and signature + * + * item-extension ::= %% attr-id + * | %% attr-id(structure-item) + * + * attr-payload ::= structure-item + * + * ~moduleLanguage represents whether we're on the module level or not + *) +and parseExtension ?(moduleLanguage=false) p = + let startPos = p.Parser.startPos in + if moduleLanguage then + Parser.expect PercentPercent p + else + Parser.expect Percent p; + let attrId = parseAttributeId ~startPos p in + let payload = parsePayload p in + (attrId, payload) diff --git a/analysis/src/vendor/res_outcome_printer/res_core.mli b/analysis/src/vendor/res_outcome_printer/res_core.mli new file mode 100644 index 000000000..760881cd6 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_core.mli @@ -0,0 +1,4 @@ +val parseImplementation: + Res_parser.t -> Parsetree.structure +val parseSpecification: + Res_parser.t -> Parsetree.signature diff --git a/analysis/src/vendor/res_outcome_printer/res_diagnostics.ml b/analysis/src/vendor/res_outcome_printer/res_diagnostics.ml new file mode 100644 index 000000000..843d3e428 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_diagnostics.ml @@ -0,0 +1,182 @@ +module Grammar = Res_grammar +module Token = Res_token + +type category = + | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} + | Expected of {context: Grammar.t option; pos: Lexing.position (* prev token end*); token: Token.t} + | Message of string + | Uident of Token.t + | Lident of Token.t + | UnclosedString + | UnclosedTemplate + | UnclosedComment + | UnknownUchar of Char.t + +type t = { + startPos: Lexing.position; + endPos: Lexing.position; + category: category; +} + +type report = t list + +let getStartPos t = t.startPos +let getEndPos t = t.endPos + +let defaultUnexpected token = + "I'm not sure what to parse here when looking at \"" ^ (Token.toString token) ^ "\"." + +let reservedKeyword token = + let tokenTxt = Token.toString token in + "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt ^ "\"" + +let explain t = + match t.category with + | Uident currentToken -> + begin match currentToken with + | Lident lident -> + let guess = String.capitalize_ascii lident in + "Did you mean `" ^ guess ^"` instead of `" ^ lident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token ^ "` is a reserved keyword." + | _ -> + "At this point, I'm looking for an uppercased name like `Belt` or `Array`" + end + | Lident currentToken -> + begin match currentToken with + | Uident uident -> + let guess = String.uncapitalize_ascii uident in + "Did you mean `" ^ guess ^"` instead of `" ^ uident ^ "`?" + | t when Token.isKeyword t -> + let token = Token.toString t in + "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token ^ "\"" + | Underscore -> + "`_` isn't a valid name." + | _ -> + "I'm expecting a lowercase name like `user or `age`" + end + | Message txt -> txt + | UnclosedString -> + "This string is missing a double quote at the end" + | UnclosedTemplate -> + "Did you forget to close this template expression with a backtick?" + | UnclosedComment -> + "This comment seems to be missing a closing `*/`" + | UnknownUchar uchar -> + begin match uchar with + | '^' -> + "Not sure what to do with this character.\n" ^ + " If you're trying to dereference a mutable value, use `myValue.contents` instead.\n" ^ + " To concatenate strings, use `\"a\" ++ \"b\"` instead." + | _ -> + "Not sure what to do with this character." + end + | Expected {context; token = t} -> + let hint = match context with + | Some grammar -> " It signals the start of " ^ (Grammar.toString grammar) + | None -> "" + in + "Did you forget a `" ^ (Token.toString t) ^ "` here?" ^ hint + | Unexpected {token = t; context = breadcrumbs} -> + let name = (Token.toString t) in + begin match breadcrumbs with + | (AtomicTypExpr, _)::breadcrumbs -> + begin match breadcrumbs, t with + | ((StringFieldDeclarations | FieldDeclarations) , _) :: _, (String _ | At | Rbrace | Comma | Eof) -> + "I'm missing a type here" + | _, t when Grammar.isStructureItemStart t || t = Eof -> + "Missing a type here" + | _ -> + defaultUnexpected t + end + | (ExprOperand, _)::breadcrumbs -> + begin match breadcrumbs, t with + | (ExprBlock, _) :: _, Rbrace -> + "It seems that this expression block is empty" + | (ExprBlock, _) :: _, Bar -> (* Pattern matching *) + "Looks like there might be an expression missing here" + | (ExprSetField, _) :: _, _ -> + "It seems that this record field mutation misses an expression" + | (ExprArrayMutation, _) :: _, _ -> + "Seems that an expression is missing, with what do I mutate the array?" + | ((ExprBinaryAfterOp _ | ExprUnary), _) ::_, _ -> + "Did you forget to write an expression here?" + | (Grammar.LetBinding, _)::_, _ -> + "This let-binding misses an expression" + | _::_, (Rbracket | Rbrace | Eof) -> + "Missing expression" + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + end + | (TypeParam, _)::_ -> + begin match t with + | Lident ident -> + "Did you mean '" ^ ident ^"? A Type parameter starts with a quote." + | _ -> + "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + end + | (Pattern, _)::breadcrumbs -> + begin match t, breadcrumbs with + | (Equal, (LetBinding,_)::_) -> + "I was expecting a name for this let-binding. Example: `let message = \"hello\"`" + | (In, (ExprFor,_)::_) -> + "A for-loop has the following form: `for i in 0 to 10`. Did you forget to supply a name before `in`?" + | (EqualGreater, (PatternMatchCase,_)::_) -> + "I was expecting a pattern to match on before the `=>`" + | (token, _) when Token.isKeyword t -> + reservedKeyword token + | (token, _) -> + defaultUnexpected token + end + | _ -> + (* TODO: match on circumstance to verify Lident needed ? *) + if Token.isKeyword t then + "`" ^ name ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ (Token.toString t) ^ "\"" + else + "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + end + +let make ~startPos ~endPos category = { + startPos; + endPos; + category +} + +let printReport diagnostics src = + let rec print diagnostics src = + match diagnostics with + | [] -> () + | d::rest -> + Res_diagnostics_printing_utils.Super_location.super_error_reporter + Format.err_formatter + src + Location.{ + loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; + msg = explain d; + sub = []; + if_highlight = ""; + }; + begin match rest with + | [] -> () + | _ -> Format.fprintf Format.err_formatter "@." + end; + print rest src + in + Format.fprintf Format.err_formatter "@["; + print (List.rev diagnostics) src; + Format.fprintf Format.err_formatter "@]@." + +let unexpected token context = + Unexpected {token; context} + +let expected ?grammar pos token = + Expected {context = grammar; pos; token} + +let uident currentToken = Uident currentToken +let lident currentToken = Lident currentToken +let unclosedString = UnclosedString +let unclosedComment = UnclosedComment +let unclosedTemplate = UnclosedTemplate +let unknownUchar code = UnknownUchar code +let message txt = Message txt diff --git a/analysis/src/vendor/res_outcome_printer/res_diagnostics.mli b/analysis/src/vendor/res_outcome_printer/res_diagnostics.mli new file mode 100644 index 000000000..7855a984f --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_diagnostics.mli @@ -0,0 +1,29 @@ +module Token = Res_token +module Grammar = Res_grammar + +type t +type category +type report + +val getStartPos: t -> Lexing.position [@@live] (* for playground *) +val getEndPos: t -> Lexing.position [@@live] (* for playground *) + +val explain: t -> string [@@live] (* for playground *) + +val unexpected: Token.t -> (Grammar.t * Lexing.position) list -> category +val expected: ?grammar:Grammar.t -> Lexing.position -> Token.t -> category +val uident: Token.t -> category +val lident: Token.t -> category +val unclosedString: category +val unclosedTemplate: category +val unclosedComment: category +val unknownUchar: Char.t -> category +val message: string -> category + +val make: + startPos: Lexing.position + -> endPos: Lexing.position + -> category + -> t + +val printReport: t list -> string -> unit diff --git a/analysis/src/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml b/analysis/src/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml new file mode 100644 index 000000000..758478a43 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_diagnostics_printing_utils.ml @@ -0,0 +1,373 @@ +(* + This file is taken from ReScript's super_code_frame.ml and super_location.ml + We're copying the look of ReScript's terminal error reporting. + See https://github.com/rescript-lang/syntax/pull/77 for the rationale. + A few lines have been commented out and swapped for their tweaked version. +*) + +(* ===== super_code_frame.ml *) + +module Super_code_frame = struct + +let digits_count n = + let rec loop n base count = + if n >= base then loop n (base * 10) (count + 1) else count + in + loop (abs n) 1 0 + +let seek_2_lines_before src pos = + let open Lexing in + let original_line = pos.pos_lnum in + let rec loop current_line current_char = + if current_line + 2 >= original_line then + (current_char, current_line) + else + loop + (if (src.[current_char] [@doesNotRaise]) = '\n' then current_line + 1 else current_line) + (current_char + 1) + in + loop 1 0 + +let seek_2_lines_after src pos = + let open Lexing in + let original_line = pos.pos_lnum in + let rec loop current_line current_char = + if current_char = String.length src then + (current_char, current_line) + else + match src.[current_char] [@doesNotRaise] with + | '\n' when current_line = original_line + 2 -> + (current_char, current_line) + | '\n' -> loop (current_line + 1) (current_char + 1) + | _ -> loop current_line (current_char + 1) + in + loop original_line pos.pos_cnum + +let leading_space_count str = + let rec loop i count = + if i = String.length str then count + else if str.[i] [@doesNotRaise] != ' ' then count + else loop (i + 1) (count + 1) + in + loop 0 0 + +let break_long_line max_width line = + let rec loop pos accum = + if pos = String.length line then accum + else + let chunk_length = min max_width (String.length line - pos) in + let chunk = (String.sub [@doesNotRaise]) line pos chunk_length in + loop (pos + chunk_length) (chunk::accum) + in + loop 0 [] |> List.rev + +let filter_mapi f l = + let rec loop f l i accum = + match l with + | [] -> accum + | head::rest -> + let accum = + match f i head with + | None -> accum + | Some result -> result::accum + in + loop f rest (i + 1) accum + in + loop f l 0 [] |> List.rev + +(* Spiritual equivalent of + https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 +*) +module Color = struct + type color = + | Dim + (* | Filename *) + | Err + | Warn + | NoColor + + let dim = "\x1b[2m" + (* let filename = "\x1b[46m" *) + let err = "\x1b[1;31m" + let warn = "\x1b[1;33m" + let reset = "\x1b[0m" + + external isatty : out_channel -> bool = "caml_sys_isatty" + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" + && term <> "" + && isatty stderr + + let color_enabled = ref true + + let setup = + let first = ref true in (* initialize only once *) + fun o -> + if !first then ( + first := false; + color_enabled := (match o with + | Some Misc.Color.Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()) + ); + () +end + +let setup = Color.setup + +type gutter = Number of int | Elided +type highlighted_string = {s: string; start: int; end_: int} +type line = { + gutter: gutter; + content: highlighted_string list; +} +(* + Features: + - display a line gutter + - break long line into multiple for terminal display + - peek 2 lines before & after for context + - center snippet when it's heavily indented + - ellide intermediate lines when the reported range is huge +*) +let print ~is_warning ~src ~startPos ~endPos = + let open Lexing in + + let indent = 2 in + let highlight_line_start_line = startPos.pos_lnum in + let highlight_line_end_line = endPos.pos_lnum in + let (start_line_line_offset, first_shown_line) = seek_2_lines_before src startPos in + let (end_line_line_end_offset, last_shown_line) = seek_2_lines_after src endPos in + + let more_than_5_highlighted_lines = + highlight_line_end_line - highlight_line_start_line + 1 > 5 + in + let max_line_digits_count = digits_count last_shown_line in + (* TODO: change this back to a fixed 100? *) + (* 3 for separator + the 2 spaces around it *) + let line_width = 78 - max_line_digits_count - indent - 3 in + let lines = + (String.sub [@doesNotRaise]) src start_line_line_offset (end_line_line_end_offset - start_line_line_offset) + |> String.split_on_char '\n' + |> filter_mapi (fun i line -> + let line_number = i + first_shown_line in + if more_than_5_highlighted_lines then + if line_number = highlight_line_start_line + 2 then + Some (Elided, line) + else if line_number > highlight_line_start_line + 2 && line_number < highlight_line_end_line - 1 then None + else Some (Number line_number, line) + else Some (Number line_number, line) + ) + in + let leading_space_to_cut = lines |> List.fold_left (fun current_max (_, line) -> + let leading_spaces = leading_space_count line in + if String.length line = leading_spaces then + (* the line's nothing but spaces. Doesn't count *) + current_max + else + min leading_spaces current_max + ) 99999 + in + let separator = if leading_space_to_cut = 0 then "│" else "┆" in + let stripped_lines = lines |> List.map (fun (gutter, line) -> + let new_content = + if String.length line <= leading_space_to_cut then + [{s = ""; start = 0; end_ = 0}] + else + (String.sub [@doesNotRaise]) line leading_space_to_cut (String.length line - leading_space_to_cut) + |> break_long_line line_width + |> List.mapi (fun i line -> + match gutter with + | Elided -> {s = line; start = 0; end_ = 0} + | Number line_number -> + let highlight_line_start_offset = startPos.pos_cnum - startPos.pos_bol in + let highlight_line_end_offset = endPos.pos_cnum - endPos.pos_bol in + let start = + if i = 0 && line_number = highlight_line_start_line then + highlight_line_start_offset - leading_space_to_cut + else 0 + in + let end_ = + if line_number < highlight_line_start_line then 0 + else if line_number = highlight_line_start_line && line_number = highlight_line_end_line then + highlight_line_end_offset - leading_space_to_cut + else if line_number = highlight_line_start_line then + String.length line + else if line_number > highlight_line_start_line && line_number < highlight_line_end_line then + String.length line + else if line_number = highlight_line_end_line then highlight_line_end_offset - leading_space_to_cut + else 0 + in + {s = line; start; end_} + ) + in + {gutter; content = new_content} + ) + in + let buf = Buffer.create 100 in + let open Color in + let add_ch = + let last_color = ref NoColor in + fun color ch -> + if not !Color.color_enabled || !last_color = color then + Buffer.add_char buf ch + else begin + let ansi = match !last_color, color with + | NoColor, Dim -> dim + (* | NoColor, Filename -> filename *) + | NoColor, Err -> err + | NoColor, Warn -> warn + | _, NoColor -> reset + | _, Dim -> reset ^ dim + (* | _, Filename -> reset ^ filename *) + | _, Err -> reset ^ err + | _, Warn -> reset ^ warn + in + Buffer.add_string buf ansi; + Buffer.add_char buf ch; + last_color := color; + end + in + let draw_gutter color s = + for _i = 1 to (max_line_digits_count + indent - String.length s) do + add_ch NoColor ' ' + done; + s |> String.iter (add_ch color); + add_ch NoColor ' '; + separator |> String.iter (add_ch Dim); + add_ch NoColor ' '; + in + stripped_lines |> List.iter (fun {gutter; content} -> + match gutter with + | Elided -> + draw_gutter Dim "."; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch NoColor '\n'; + | Number line_number -> begin + content |> List.iteri (fun i line -> + let gutter_content = if i = 0 then string_of_int line_number else "" in + let gutter_color = + if i = 0 + && line_number >= highlight_line_start_line + && line_number <= highlight_line_end_line then + if is_warning then Warn else Err + else NoColor + in + draw_gutter gutter_color gutter_content; + + line.s |> String.iteri (fun ii ch -> + let c = + if ii >= line.start && ii < line.end_ then + if is_warning then Warn else Err + else NoColor in + add_ch c ch; + ); + add_ch NoColor '\n'; + ); + end + ); + Buffer.contents buf +end + + +(* ===== super_location.ml *) +module Super_location = struct + +let fprintf = Format.fprintf + +let setup_colors () = + Misc.Color.setup !Clflags.color; + Super_code_frame.setup !Clflags.color + +let print_filename = Location.print_filename + +let print_loc ~normalizedRange ppf (loc : Location.t) = + setup_colors (); + let dim_loc ppf = function + | None -> () + | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) -> + if start_line = end_line then + if start_line_start_char = end_line_end_char then + fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + else + fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char end_line_end_char + else + fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char end_line end_line_end_char + in + fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname dim_loc normalizedRange +;; + + +(* let print ~message_kind intro ppf (loc : Location.t) = *) +let print ~message_kind intro src ppf (loc : Location.t) = + begin match message_kind with + | `warning -> fprintf ppf "@[@{%s@}@]@," intro + | `warning_as_error -> fprintf ppf "@[@{%s@} (configured as error) @]@," intro + | `error -> fprintf ppf "@[@{%s@}@]@," intro + end; + (* ocaml's reported line/col numbering is horrible and super error-prone + when being handled programmatically (or humanly for that matter. If you're + an ocaml contributor reading this: who the heck reads the character count + starting from the first erroring character?) *) + (* let (file, start_line, start_char) = Location.get_pos_info loc.loc_start in *) + let (_file, start_line, start_char) = Location.get_pos_info loc.loc_start in + let (_, end_line, end_char) = Location.get_pos_info loc.loc_end in + (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) + (* start_char is inclusive, end_char is exclusive *) + let normalizedRange = + (* TODO: lots of the handlings here aren't needed anymore because the new + rescript syntax has much stronger invariants regarding positions, e.g. + no -1 *) + if start_char == -1 || end_char == -1 then + (* happens sometimes. Syntax error for example *) + None + else if start_line = end_line && start_char >= end_char then + (* in some errors, starting char and ending char can be the same. But + since ending char was supposed to be exclusive, here it might end up + smaller than the starting char if we naively did start_char + 1 to + just the starting char and forget ending char *) + let same_char = start_char + 1 in + Some ((start_line, same_char), (end_line, same_char)) + else + (* again: end_char is exclusive, so +1-1=0 *) + Some ((start_line, start_char + 1), (end_line, end_char)) + in + fprintf ppf " @[%a@]@," (print_loc ~normalizedRange) loc; + match normalizedRange with + | None -> () + | Some _ -> begin + try + (* let src = Ext_io.load_file file in *) + (* we're putting the line break `@,` here rather than above, because this + branch might not be reached (aka no inline file content display) so + we don't wanna end up with two line breaks in the the consequent *) + fprintf ppf "@,%s" + (Super_code_frame.print + ~is_warning:(message_kind=`warning) + ~src + ~startPos:loc.loc_start + ~endPos:loc.loc_end + ) + with + (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. + we've already printed the location above, so nothing more to do here. *) + | Sys_error _ -> () + end +;; + +(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) +(* This is the error report entry point. We'll replace the default reporter with this one. *) +(* let rec super_error_reporter ppf ({loc; msg; sub} : Location.error) = *) +let super_error_reporter ppf src ({loc; msg} : Location.error) = + setup_colors (); + (* open a vertical box. Everything in our message is indented 2 spaces *) + (* Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") src loc msg; *) + Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "Syntax error!" src) loc msg; + (* List.iter (Format.fprintf ppf "@,@[%a@]" super_error_reporter) sub *) +(* no need to flush here; location's report_exception (which uses this ultimately) flushes *) + +end diff --git a/analysis/src/vendor/res_outcome_printer/res_driver.ml b/analysis/src/vendor/res_outcome_printer/res_driver.ml new file mode 100644 index 000000000..d827880ac --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver.ml @@ -0,0 +1,109 @@ +module IO = Res_io + +type ('ast, 'diagnostics) parseResult = { + filename: string; [@live] + source: string; + parsetree: 'ast; + diagnostics: 'diagnostics; + invalid: bool; + comments: Res_comment.t list +} + +type ('diagnostics) parsingEngine = { + parseImplementation: + forPrinter:bool -> filename:string + -> (Parsetree.structure, 'diagnostics) parseResult; + parseInterface: + forPrinter:bool -> filename:string + -> (Parsetree.signature, 'diagnostics) parseResult; + stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit +} + +type printEngine = { + printImplementation: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.structure + -> unit; + printInterface: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.signature + -> unit; +} + +let setup ~filename ~forPrinter () = + let src = IO.readFile ~filename in + let mode = if forPrinter then Res_parser.Default + else ParseForTypeChecker + in + Res_parser.make ~mode src filename + +let parsingEngine = { + parseImplementation = begin fun ~forPrinter ~filename -> + let engine = setup ~filename ~forPrinter () in + let structure = Res_core.parseImplementation engine in + let (invalid, diagnostics) = match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = structure; + diagnostics; + invalid; + comments = List.rev engine.comments; + } + end; + parseInterface = begin fun ~forPrinter ~filename -> + let engine = setup ~filename ~forPrinter () in + let signature = Res_core.parseSpecification engine in + let (invalid, diagnostics) = match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = signature; + diagnostics; + invalid; + comments = List.rev engine.comments; + } + end; + stringOfDiagnostics = begin fun ~source ~filename:_ diagnostics -> + Res_diagnostics.printReport diagnostics source + end; +} + +let printEngine = { + printImplementation = begin fun ~width ~filename:_ ~comments structure -> + print_string (Res_printer.printImplementation ~width structure ~comments) + end; + printInterface = begin fun ~width ~filename:_ ~comments signature -> + print_string (Res_printer.printInterface ~width signature ~comments) + end; +} + +let parse_implementation sourcefile = + Location.input_name := sourcefile; + let parseResult = + parsingEngine.parseImplementation ~forPrinter:false ~filename:sourcefile + in + if parseResult.invalid then begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end; + parseResult.parsetree +[@@raises exit] + +let parse_interface sourcefile = + Location.input_name := sourcefile; + let parseResult = parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile in + if parseResult.invalid then begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end; + parseResult.parsetree +[@@raises exit] diff --git a/analysis/src/vendor/res_outcome_printer/res_driver.mli b/analysis/src/vendor/res_outcome_printer/res_driver.mli new file mode 100644 index 000000000..0facc0a52 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver.mli @@ -0,0 +1,49 @@ +type ('ast, 'diagnostics) parseResult = { + filename: string; [@live] + source: string; + parsetree: 'ast; + diagnostics: 'diagnostics; + invalid: bool; + comments: Res_comment.t list +} + +type ('diagnostics) parsingEngine = { + parseImplementation: + forPrinter:bool -> filename:string + -> (Parsetree.structure, 'diagnostics) parseResult; + parseInterface: + forPrinter:bool -> filename:string + -> (Parsetree.signature, 'diagnostics) parseResult; + stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit +} + +type printEngine = { + printImplementation: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.structure + -> unit; + printInterface: + width: int + -> filename: string + -> comments: Res_comment.t list + -> Parsetree.signature + -> unit; +} + +val parsingEngine: (Res_diagnostics.t list) parsingEngine + +val printEngine: printEngine + +(* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) +val parse_implementation: + string -> Parsetree.structure +[@@live] +[@@raises Location.Error] + +(* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) +val parse_interface: + string -> Parsetree.signature +[@@live] +[@@raises Location.Error] diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_binary.ml b/analysis/src/vendor/res_outcome_printer/res_driver_binary.ml new file mode 100644 index 000000000..408515578 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_binary.ml @@ -0,0 +1,12 @@ +let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename ~comments:_ structure -> + output_string stdout Config.ast_impl_magic_number; + output_value stdout filename; + output_value stdout structure + end; + printInterface = begin fun ~width:_ ~filename ~comments:_ signature -> + output_string stdout Config.ast_intf_magic_number; + output_value stdout filename; + output_value stdout signature + end; +} diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_binary.mli b/analysis/src/vendor/res_outcome_printer/res_driver_binary.mli new file mode 100644 index 000000000..7991ba8db --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_binary.mli @@ -0,0 +1 @@ +val printEngine : Res_driver.printEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.ml b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.ml new file mode 100644 index 000000000..221a31c5d --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.ml @@ -0,0 +1,92 @@ +module OcamlParser = Parser +module IO = Res_io + +let setup ~filename = + if String.length filename > 0 then ( + Location.input_name := filename; + IO.readFile ~filename |> Lexing.from_string + ) else + Lexing.from_channel stdin + +let extractOcamlConcreteSyntax filename = + let lexbuf = if String.length filename > 0 then + IO.readFile ~filename |> Lexing.from_string + else + Lexing.from_channel stdin + in + let stringLocs = ref [] in + let commentData = ref [] in + let rec next (prevTokEndPos : Lexing.position) () = + let token = Lexer.token_with_comments lexbuf in + match token with + | OcamlParser.COMMENT (txt, loc) -> + let comment = Res_comment.fromOcamlComment + ~loc + ~prevTokEndPos + ~txt + in + commentData := comment::(!commentData); + next loc.Location.loc_end () + | OcamlParser.STRING (_txt, None) -> + let open Location in + let loc = { + loc_start = lexbuf.lex_start_p; + loc_end = lexbuf.Lexing.lex_curr_p; + loc_ghost = false; + } in + let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in + let txt = Bytes.to_string ( + (Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer loc.loc_start.pos_cnum len + ) in + stringLocs := (txt, loc)::(!stringLocs); + next lexbuf.Lexing.lex_curr_p () + | OcamlParser.EOF -> () + | _ -> next lexbuf.Lexing.lex_curr_p () + in + next lexbuf.Lexing.lex_start_p (); + (List.rev !stringLocs, List.rev !commentData) + +let parsingEngine = { + Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename -> + let lexbuf = setup ~filename in + let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in + let structure = + Parse.implementation lexbuf + |> Res_ast_conversion.replaceStringLiteralStructure stringData + |> Res_ast_conversion.structure + in { + filename = !Location.input_name; + source = Bytes.to_string lexbuf.lex_buffer; + parsetree = structure; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + parseInterface = begin fun ~forPrinter:_ ~filename -> + let lexbuf = setup ~filename in + let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in + let signature = + Parse.interface lexbuf + |> Res_ast_conversion.replaceStringLiteralSignature stringData + |> Res_ast_conversion.signature + in { + filename = !Location.input_name; + source = Bytes.to_string lexbuf.lex_buffer; + parsetree = signature; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end; +} + +let printEngine = Res_driver.{ + printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ structure -> + Pprintast.structure Format.std_formatter structure + end; + printInterface = begin fun ~width:_ ~filename:_ ~comments:_ signature -> + Pprintast.signature Format.std_formatter signature + end; +} diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.mli b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.mli new file mode 100644 index 000000000..4743e229a --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_ml_parser.mli @@ -0,0 +1,9 @@ +(* This module represents a general interface to parse marshalled reason ast *) + +(* extracts comments and the original string data from an ocaml file *) +val extractOcamlConcreteSyntax : + string -> (string * Location.t) list * Res_comment.t list [@@live] + +val parsingEngine : unit Res_driver.parsingEngine + +val printEngine : Res_driver.printEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.ml b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.ml new file mode 100644 index 000000000..ad1beac74 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.ml @@ -0,0 +1,103 @@ +module IO = Res_io + +let isReasonDocComment (comment: Res_comment.t) = + let content = Res_comment.txt comment in + let len = String.length content in + if len = 0 then true + else if len >= 2 && (String.unsafe_get content 0 = '*' && String.unsafe_get content 1 = '*') then false + else if len >= 1 && (String.unsafe_get content 0 = '*') then true + else false + +let extractConcreteSyntax filename = + let commentData = ref [] in + let stringData = ref [] in + let src = IO.readFile ~filename in + let scanner = Res_scanner.make src ~filename in + + let rec next prevEndPos scanner = + let (startPos, endPos, token) = Res_scanner.scan scanner in + match token with + | Eof -> () + | Comment c -> + Res_comment.setPrevTokEndPos c prevEndPos; + commentData := c::(!commentData); + next endPos scanner + | String _ -> + let loc = {Location.loc_start = startPos; loc_end = endPos; loc_ghost = false} in + let len = endPos.pos_cnum - startPos.pos_cnum in + let txt = (String.sub [@doesNotRaise]) src startPos.pos_cnum len in + stringData := (txt, loc)::(!stringData); + next endPos scanner; + | Lbrace -> + (* handle {| |} or {sql||sql} quoted strings. We don't care about its contents. + Why? // abcdef inside the quoted string would otherwise be picked up as an extra comment *) + Res_scanner.tryAdvanceQuotedString scanner; + next endPos scanner + | _ -> + next endPos scanner + in + next Lexing.dummy_pos scanner; + let comments = + !commentData + |> List.filter (fun c -> not (isReasonDocComment c)) + |> List.rev + in + (comments, !stringData) + +let parsingEngine = { + Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename -> + let (chan, close) = if (String.length filename) == 0 then + (stdin, fun _ -> ()) + else + let file_chan = open_in_bin filename in + let () = seek_in file_chan 0 in + file_chan, close_in_noerr + in + let magic = Config.ast_impl_magic_number in + ignore ((really_input_string [@doesNotRaise]) chan (String.length magic)); + let filename = input_value chan in + let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in + let ast = input_value chan in + close chan; + let structure = ast + |> Res_ast_conversion.replaceStringLiteralStructure stringData + |> Res_ast_conversion.normalizeReasonArityStructure ~forPrinter:true + |> Res_ast_conversion.structure + in { + Res_driver.filename = filename; + source = ""; + parsetree = structure; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + parseInterface = begin fun ~forPrinter:_ ~filename -> + let (chan, close) = if String.length filename == 0 then + (stdin, fun _ -> ()) + else + let file_chan = open_in_bin filename in + let () = seek_in file_chan 0 in + file_chan, close_in_noerr + in + let magic = Config.ast_intf_magic_number in + ignore ((really_input_string [@doesNotRaise]) chan (String.length magic)); + let filename = input_value chan in + let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in + let ast = input_value chan in + close chan; + let signature = ast + |> Res_ast_conversion.replaceStringLiteralSignature stringData + |> Res_ast_conversion.normalizeReasonAritySignature ~forPrinter:true + |> Res_ast_conversion.signature + in { + Res_driver.filename; + source = ""; + parsetree = signature; + diagnostics = (); + invalid = false; + comments = comments; + } + end; + stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end; +} diff --git a/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.mli b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.mli new file mode 100644 index 000000000..dce2d65ad --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_driver_reason_binary.mli @@ -0,0 +1,7 @@ +(* This module represents a general interface to parse marshalled reason ast *) + +(* extracts comments and the original string data from a reason file *) +val extractConcreteSyntax : + string -> Res_token.Comment.t list * (string * Location.t) list + +val parsingEngine : unit Res_driver.parsingEngine diff --git a/analysis/src/vendor/res_outcome_printer/res_grammar.ml b/analysis/src/vendor/res_outcome_printer/res_grammar.ml new file mode 100644 index 000000000..394bdd960 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_grammar.ml @@ -0,0 +1,368 @@ +module Token = Res_token + +type t = + | OpenDescription (* open Belt *) + | ModuleLongIdent (* Foo or Foo.Bar *) [@live] + | Ternary (* condExpr ? trueExpr : falseExpr *) + | Es6ArrowExpr + | Jsx + | JsxAttribute + | JsxChild [@live] + | ExprOperand + | ExprUnary + | ExprSetField + | ExprBinaryAfterOp of Token.t + | ExprBlock + | ExprCall + | ExprList + | ExprArrayAccess + | ExprArrayMutation + | ExprIf + | ExprFor + | IfCondition | IfBranch | ElseBranch + | TypeExpression + | External + | PatternMatching + | PatternMatchCase + | LetBinding + | PatternList + | PatternOcamlList + | PatternRecord + + | TypeDef + | TypeConstrName + | TypeParams + | TypeParam [@live] + | PackageConstraint + | TypeRepresentation + | RecordDecl + | ConstructorDeclaration + | ParameterList + | StringFieldDeclarations + | FieldDeclarations + | TypExprList + | FunctorArgs + | ModExprList + | TypeParameters + | RecordRows + | RecordRowsStringKey + | ArgumentList + | Signature + | Specification + | Structure + | Implementation + | Attribute + | TypeConstraint + | AtomicTypExpr + | ListExpr + | JsFfiImport + | Pattern + | AttributePayload + +let toString = function + | OpenDescription -> "an open description" + | ModuleLongIdent -> "a module path" + | Ternary -> "a ternary expression" + | Es6ArrowExpr -> "an es6 arrow function" + | Jsx -> "a jsx expression" + | JsxAttribute -> "a jsx attribute" + | ExprOperand -> "a basic expression" + | ExprUnary -> "a unary expression" + | ExprBinaryAfterOp op -> "an expression after the operator \"" ^ Token.toString op ^ "\"" + | ExprIf -> "an if expression" + | IfCondition -> "the condition of an if expression" + | IfBranch -> "the true-branch of an if expression" + | ElseBranch -> "the else-branch of an if expression" + | TypeExpression -> "a type" + | External -> "an external" + | PatternMatching -> "the cases of a pattern match" + | ExprBlock -> "a block with expressions" + | ExprSetField -> "a record field mutation" + | ExprCall -> "a function application" + | ExprArrayAccess -> "an array access expression" + | ExprArrayMutation -> "an array mutation" + | LetBinding -> "a let binding" + | TypeDef -> "a type definition" + | TypeParams -> "type parameters" + | TypeParam -> "a type parameter" + | TypeConstrName -> "a type-constructor name" + | TypeRepresentation -> "a type representation" + | RecordDecl -> "a record declaration" + | PatternMatchCase -> "a pattern match case" + | ConstructorDeclaration -> "a constructor declaration" + | ExprList -> "multiple expressions" + | PatternList -> "multiple patterns" + | PatternOcamlList -> "a list pattern" + | PatternRecord -> "a record pattern" + | ParameterList -> "parameters" + | StringFieldDeclarations -> "string field declarations" + | FieldDeclarations -> "field declarations" + | TypExprList -> "list of types" + | FunctorArgs -> "functor arguments" + | ModExprList -> "list of module expressions" + | TypeParameters -> "list of type parameters" + | RecordRows -> "rows of a record" + | RecordRowsStringKey -> "rows of a record with string keys" + | ArgumentList -> "arguments" + | Signature -> "signature" + | Specification -> "specification" + | Structure -> "structure" + | Implementation -> "implementation" + | Attribute -> "an attribute" + | TypeConstraint -> "constraints on a type" + | AtomicTypExpr -> "a type" + | ListExpr -> "an ocaml list expr" + | PackageConstraint -> "a package constraint" + | JsFfiImport -> "js ffi import" + | JsxChild -> "jsx child" + | Pattern -> "pattern" + | ExprFor -> "a for expression" + | AttributePayload -> "an attribute payload" + +let isSignatureItemStart = function + | Token.At + | Let + | Typ + | External + | Exception + | Open + | Include + | Module + | AtAt + | Export + | PercentPercent -> true + | _ -> false + +let isAtomicPatternStart = function + | Token.Int _ | String _ | Character _ | Backtick + | Lparen | Lbracket | Lbrace + | Underscore + | Lident _ | Uident _ | List + | Exception | Lazy + | Percent -> true + | _ -> false + +let isAtomicExprStart = function + | Token.True | False + | Int _ | String _ | Float _ | Character _ + | Backtick + | Uident _ | Lident _ | Hash + | Lparen + | List + | Lbracket + | Lbrace + | LessThan + | Module + | Percent -> true + | _ -> false + +let isAtomicTypExprStart = function + | Token.SingleQuote | Underscore + | Lparen | Lbrace + | Uident _ | Lident _ + | Percent -> true + | _ -> false + +let isExprStart = function + | Token.True | False + | Int _ | String _ | Float _ | Character _ | Backtick + | Underscore (* _ => doThings() *) + | Uident _ | Lident _ | Hash + | Lparen | List | Module | Lbracket | Lbrace + | LessThan + | Minus | MinusDot | Plus | PlusDot | Bang + | Percent | At + | If | Switch | While | For | Assert | Lazy | Try -> true + | _ -> false + +let isJsxAttributeStart = function + | Token.Lident _ | Question -> true + | _ -> false + +let isStructureItemStart = function + | Token.Open + | Let + | Typ + | External | Import | Export + | Exception + | Include + | Module + | AtAt + | PercentPercent + | At -> true + | t when isExprStart t -> true + | _ -> false + +let isPatternStart = function + | Token.Int _ | Float _ | String _ | Character _ | Backtick | True | False | Minus | Plus + | Lparen | Lbracket | Lbrace | List + | Underscore + | Lident _ | Uident _ | Hash + | Exception | Lazy | Percent | Module + | At -> true + | _ -> false + +let isParameterStart = function + | Token.Typ | Tilde | Dot -> true + | token when isPatternStart token -> true + | _ -> false + +(* TODO: overparse Uident ? *) +let isStringFieldDeclStart = function + | Token.String _ | Lident _ | At | DotDotDot -> true + | _ -> false + +(* TODO: overparse Uident ? *) +let isFieldDeclStart = function + | Token.At | Mutable | Lident _ -> true + (* recovery, TODO: this is not ideal… *) + | Uident _ -> true + | t when Token.isKeyword t -> true + | _ -> false + +let isRecordDeclStart = function + | Token.At + | Mutable + | Lident _ -> true + | _ -> false + +let isTypExprStart = function + | Token.At + | SingleQuote + | Underscore + | Lparen | Lbracket + | Uident _ | Lident _ + | Module + | Percent + | Lbrace -> true + | _ -> false + +let isTypeParameterStart = function + | Token.Tilde | Dot -> true + | token when isTypExprStart token -> true + | _ -> false + +let isTypeParamStart = function + | Token.Plus | Minus | SingleQuote | Underscore -> true + | _ -> false + +let isFunctorArgStart = function + | Token.At | Uident _ | Underscore + | Percent + | Lbrace + | Lparen -> true + | _ -> false + +let isModExprStart = function + | Token.At | Percent + | Uident _ | Lbrace | Lparen + | Lident "unpack" -> true + | _ -> false + +let isRecordRowStart = function + | Token.DotDotDot -> true + | Token.Uident _ | Lident _ -> true + (* TODO *) + | t when Token.isKeyword t -> true + | _ -> false + +let isRecordRowStringKeyStart = function + | Token.String _ -> true + | _ -> false + +let isArgumentStart = function + | Token.Tilde | Dot | Underscore -> true + | t when isExprStart t -> true + | _ -> false + +let isPatternMatchStart = function + | Token.Bar -> true + | t when isPatternStart t -> true + | _ -> false + +let isPatternOcamlListStart = function + | Token.DotDotDot -> true + | t when isPatternStart t -> true + | _ -> false + +let isPatternRecordItemStart = function + | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true + | _ -> false + +let isAttributeStart = function + | Token.At -> true + | _ -> false + +let isJsFfiImportStart = function + | Token.Lident _ | At -> true + | _ -> false + +let isJsxChildStart = isAtomicExprStart + +let isBlockExprStart = function + | Token.At | Hash | Percent | Minus | MinusDot | Plus | PlusDot | Bang + | True | False | Float _ | Int _ | String _ | Character _ | Lident _ | Uident _ + | Lparen | List | Lbracket | Lbrace | Forwardslash | Assert + | Lazy | If | For | While | Switch | Open | Module | Exception | Let + | LessThan | Backtick | Try | Underscore -> true + | _ -> false + +let isListElement grammar token = + match grammar with + | ExprList -> token = Token.DotDotDot || isExprStart token + | ListExpr -> token = DotDotDot || isExprStart token + | PatternList -> token = DotDotDot || isPatternStart token + | ParameterList -> isParameterStart token + | StringFieldDeclarations -> isStringFieldDeclStart token + | FieldDeclarations -> isFieldDeclStart token + | RecordDecl -> isRecordDeclStart token + | TypExprList -> isTypExprStart token || token = Token.LessThan + | TypeParams -> isTypeParamStart token + | FunctorArgs -> isFunctorArgStart token + | ModExprList -> isModExprStart token + | TypeParameters -> isTypeParameterStart token + | RecordRows -> isRecordRowStart token + | RecordRowsStringKey -> isRecordRowStringKeyStart token + | ArgumentList -> isArgumentStart token + | Signature | Specification -> isSignatureItemStart token + | Structure | Implementation -> isStructureItemStart token + | PatternMatching -> isPatternMatchStart token + | PatternOcamlList -> isPatternOcamlListStart token + | PatternRecord -> isPatternRecordItemStart token + | Attribute -> isAttributeStart token + | TypeConstraint -> token = Constraint + | PackageConstraint -> token = And + | ConstructorDeclaration -> token = Bar + | JsxAttribute -> isJsxAttributeStart token + | JsFfiImport -> isJsFfiImportStart token + | AttributePayload -> token = Lparen + | _ -> false + +let isListTerminator grammar token = + match grammar, token with + | _, Token.Eof + | ExprList, (Rparen | Forwardslash | Rbracket) + | ListExpr, Rparen + | ArgumentList, Rparen + | TypExprList, (Rparen | Forwardslash | GreaterThan | Equal) + | ModExprList, Rparen + | (PatternList | PatternOcamlList | PatternRecord), + (Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) | In (* for expressions *) | Equal (* let {x} = foo *)) + | ExprBlock, Rbrace + | (Structure | Signature), Rbrace + | TypeParams, Rparen + | ParameterList, (EqualGreater | Lbrace) + | JsxAttribute, (Forwardslash | GreaterThan) + | JsFfiImport, Rbrace + | StringFieldDeclarations, Rbrace -> true + + | Attribute, token when token <> At -> true + | TypeConstraint, token when token <> Constraint -> true + | PackageConstraint, token when token <> And -> true + | ConstructorDeclaration, token when token <> Bar -> true + | AttributePayload, Rparen -> true + + | _ -> false + +let isPartOfList grammar token = + isListElement grammar token || isListTerminator grammar token diff --git a/analysis/src/vendor/res_outcome_printer/res_io.ml b/analysis/src/vendor/res_outcome_printer/res_io.ml new file mode 100644 index 000000000..e5934b848 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_io.ml @@ -0,0 +1,14 @@ +let readFile ~filename = + let chan = open_in_bin filename in + let content = + try really_input_string chan (in_channel_length chan) + with End_of_file -> "" + in + close_in_noerr chan; + content + +let writeFile ~filename ~contents:txt = + let chan = open_out_bin filename in + output_string chan txt; + close_out chan +[@@raises Sys_error] diff --git a/analysis/src/vendor/res_outcome_printer/res_io.mli b/analysis/src/vendor/res_outcome_printer/res_io.mli new file mode 100644 index 000000000..6260c27c5 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_io.mli @@ -0,0 +1,7 @@ +(* utilities to read and write to/from files or stdin *) + +(* reads the contents of "filename" into a string *) +val readFile: filename: string -> string + +(* writes "content" into file with name "filename" *) +val writeFile: filename: string -> contents: string -> unit diff --git a/analysis/src/vendor/res_outcome_printer/res_js_ffi.ml b/analysis/src/vendor/res_outcome_printer/res_js_ffi.ml new file mode 100644 index 000000000..f8a082a19 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_js_ffi.ml @@ -0,0 +1,116 @@ +(* AST for js externals *) +type scope = + | Global + | Module of string (* bs.module("path") *) + | Scope of Longident.t (* bs.scope(/"window", "location"/) *) + +type label_declaration = { + jld_attributes: Parsetree.attributes; [@live] + jld_name: string; + jld_alias: string; + jld_type: Parsetree.core_type; + jld_loc: Location.t +} + +type importSpec = + | Default of label_declaration + | Spec of label_declaration list + +type import_description = { + jid_loc: Location.t; + jid_spec: importSpec; + jid_scope: scope; + jid_attributes: Parsetree.attributes; +} + +let decl ~attrs ~loc ~name ~alias ~typ = { + jld_loc = loc; + jld_attributes = attrs; + jld_name = name; + jld_alias = alias; + jld_type = typ +} + +let importDescr ~attrs ~scope ~importSpec ~loc = { + jid_loc = loc; + jid_spec = importSpec; + jid_scope = scope; + jid_attributes = attrs; +} + +let toParsetree importDescr = + let bsVal = (Location.mknoloc "val", Parsetree.PStr []) in + let attrs = match importDescr.jid_scope with + | Global -> [bsVal] + (* @genType.import("./MyMath"), + * @genType.import(/"./MyMath", "default"/) *) + | Module s -> + let structure = [ + Parsetree.Pconst_string (s, None) + |> Ast_helper.Exp.constant + |> Ast_helper.Str.eval + ] in + let genType = (Location.mknoloc "genType.import", Parsetree.PStr structure) in + [genType] + | Scope longident -> + let structureItem = + let expr = match Longident.flatten longident |> List.map (fun s -> + Ast_helper.Exp.constant (Parsetree.Pconst_string (s, None)) + ) with + | [expr] -> expr + | [] as exprs | (_ as exprs) -> exprs |> Ast_helper.Exp.tuple + in + Ast_helper.Str.eval expr + in + let bsScope = ( + Location.mknoloc "scope", + Parsetree. PStr [structureItem] + ) in + [bsVal; bsScope] + in + let valueDescrs = match importDescr.jid_spec with + | Default decl -> + let prim = [decl.jld_name] in + let allAttrs = + List.concat [attrs; importDescr.jid_attributes] + |> List.map (fun attr -> match attr with + | ( + {Location.txt = "genType.import"} as id, + Parsetree.PStr [{pstr_desc = Parsetree.Pstr_eval (moduleName, _) }] + ) -> + let default = + Parsetree.Pconst_string ("default", None) |> Ast_helper.Exp.constant + in + let structureItem = + [moduleName; default] + |> Ast_helper.Exp.tuple + |> Ast_helper.Str.eval + in + (id, Parsetree.PStr [structureItem]) + | attr -> attr + ) + in + [Ast_helper.Val.mk + ~loc:importDescr.jid_loc + ~prim + ~attrs:allAttrs + (Location.mknoloc decl.jld_alias) + decl.jld_type + |> Ast_helper.Str.primitive] + | Spec decls -> + List.map (fun decl -> + let prim = [decl.jld_name] in + let allAttrs = List.concat [attrs; decl.jld_attributes] in + Ast_helper.Val.mk + ~loc:importDescr.jid_loc + ~prim + ~attrs:allAttrs + (Location.mknoloc decl.jld_alias) + decl.jld_type + |> Ast_helper.Str.primitive ~loc:decl.jld_loc + ) decls + in + let jsFfiAttr = (Location.mknoloc "ns.jsFfi", Parsetree.PStr []) in + Ast_helper.Mod.structure ~loc:importDescr.jid_loc valueDescrs + |> Ast_helper.Incl.mk ~attrs:[jsFfiAttr] ~loc:importDescr.jid_loc + |> Ast_helper.Str.include_ ~loc:importDescr.jid_loc diff --git a/analysis/src/vendor/res_outcome_printer/res_multi_printer.ml b/analysis/src/vendor/res_outcome_printer/res_multi_printer.ml new file mode 100644 index 000000000..cfcf19427 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_multi_printer.ml @@ -0,0 +1,128 @@ +module IO = Res_io + +let defaultPrintWidth = 100 + +(* print res files to res syntax *) +let printRes ~isInterface ~filename = + if isInterface then + let parseResult = + Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename + in + if parseResult.invalid then + begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end + else + Res_printer.printInterface + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + else + let parseResult = + Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename + in + if parseResult.invalid then + begin + Res_diagnostics.printReport parseResult.diagnostics parseResult.source; + exit 1 + end + else + Res_printer.printImplementation + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree +[@@raises exit] + +(* print ocaml files to res syntax *) +let printMl ~isInterface ~filename = + if isInterface then + let parseResult = + Res_driver_ml_parser.parsingEngine.parseInterface ~forPrinter:true ~filename in + Res_printer.printInterface + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + else + let parseResult = + Res_driver_ml_parser.parsingEngine.parseImplementation ~forPrinter:true ~filename in + Res_printer.printImplementation + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + +(* How does printing Reason to Res work? + * -> open a tempfile + * -> write the source code found in "filename" into the tempfile + * -> run refmt in-place in binary mode on the tempfile, + * mutates contents tempfile with marshalled AST.j + * -> read the marshalled ast (from the binary output in the tempfile) + * -> re-read the original "filename" and extract string + comment data + * -> put the comment- and string data back into the unmarshalled parsetree + * -> pretty print to res + * -> take a deep breath and exhale slowly *) +let printReason ~refmtPath ~isInterface ~filename = + (* open a tempfile *) + let (tempFilename, chan) = + (* refmt is just a prefix, `open_temp_file` takes care of providing a random name + * It tries 1000 times in the case of a name conflict. + * In practise this means that we shouldn't worry too much about filesystem races *) + Filename.open_temp_file "refmt" (if isInterface then ".rei" else ".re") in + close_out chan; + (* Write the source code found in "filename" into the tempfile *) + IO.writeFile ~filename:tempFilename ~contents:(IO.readFile ~filename); + let cmd = Printf.sprintf "%s --print=binary --in-place --interface=%b %s" refmtPath isInterface tempFilename in + (* run refmt in-place in binary mode on the tempfile *) + ignore (Sys.command cmd); + let result = + if isInterface then + let parseResult = + (* read the marshalled ast (from the binary output in the tempfile) *) + Res_driver_reason_binary.parsingEngine.parseInterface ~forPrinter:true ~filename:tempFilename in + (* re-read the original "filename" and extract string + comment data *) + let (comments, stringData) = Res_driver_reason_binary.extractConcreteSyntax filename in + (* put the comment- and string data back into the unmarshalled parsetree *) + let parseResult = { + parseResult with + parsetree = + parseResult.parsetree |> Res_ast_conversion.replaceStringLiteralSignature stringData; + comments = comments; + } in + (* pretty print to res *) + Res_printer.printInterface + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + else + let parseResult = + (* read the marshalled ast (from the binary output in the tempfile) *) + Res_driver_reason_binary.parsingEngine.parseImplementation ~forPrinter:true ~filename:tempFilename in + let (comments, stringData) = Res_driver_reason_binary.extractConcreteSyntax filename in + (* put the comment- and string data back into the unmarshalled parsetree *) + let parseResult = { + parseResult with + parsetree = + parseResult.parsetree |> Res_ast_conversion.replaceStringLiteralStructure stringData; + comments = comments; + } in + (* pretty print to res *) + Res_printer.printImplementation + ~width:defaultPrintWidth + ~comments:parseResult.comments + parseResult.parsetree + in + Sys.remove tempFilename; + result +[@@raises Sys_error] + +(* print the given file named input to from "language" to res, general interface exposed by the compiler *) +let print language ~input = + let isInterface = + let len = String.length input in + len > 0 && String.unsafe_get input (len - 1) = 'i' + in + match language with + | `res -> printRes ~isInterface ~filename:input + | `ml -> printMl ~isInterface ~filename:input + | `refmt path -> printReason ~refmtPath:path ~isInterface ~filename:input +[@@raises Sys_error, exit] diff --git a/analysis/src/vendor/res_outcome_printer/res_multi_printer.mli b/analysis/src/vendor/res_outcome_printer/res_multi_printer.mli new file mode 100644 index 000000000..1a1d9624d --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_multi_printer.mli @@ -0,0 +1,3 @@ +(* Interface to print source code from different languages to res. + * Takes a filename called "input" and returns the corresponding formatted res syntax *) +val print: [`ml | `res | `refmt of string (* path to refmt *)] -> input: string -> string diff --git a/analysis/src/vendor/res_outcome_printer/res_outcome_printer.mli b/analysis/src/vendor/res_outcome_printer/res_outcome_printer.mli new file mode 100644 index 000000000..674a5eeb1 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_outcome_printer.mli @@ -0,0 +1,16 @@ +(* For the curious: the outcome printer is a printer to print data + * from the outcometree.mli file in the ocaml compiler. + * The outcome tree is used by: + * - ocaml's toplevel/repl, print results/errors + * - super errors, print nice errors + * - editor tooling, e.g. show type on hover + * + * In general it represent messages to show results or errors to the user. *) + +val parenthesized_ident : string -> bool [@@live] + +val setup : unit lazy_t [@@live] + +(* Needed for e.g. the playground to print typedtree data *) +val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live] +val printOutSigItemDoc : Outcometree.out_sig_item -> Res_doc.t [@@live] diff --git a/analysis/src/vendor/res_outcome_printer/res_parens.ml b/analysis/src/vendor/res_outcome_printer/res_parens.ml new file mode 100644 index 000000000..948f36925 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parens.ml @@ -0,0 +1,416 @@ +module ParsetreeViewer = Res_parsetree_viewer +type kind = Parenthesized | Braced of Location.t | Nothing + + let expr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | _ -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing + end + + let callExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | _ -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | _ when ParsetreeViewer.isUnaryExpression expr || ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let structureExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | _ when ParsetreeViewer.hasAttributes expr.pexp_attributes && + not (ParsetreeViewer.isJsxExpression expr) -> Parenthesized + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing + end + + let unaryExprOperand expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | expr when + ParsetreeViewer.isUnaryExpression expr || + ParsetreeViewer.isBinaryExpression expr + -> Parenthesized + | {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_extension _ (* readability? maybe remove *) + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let binaryExprOperand ~isLhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _} -> Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + } when isLhs -> Parenthesized + | _ -> Nothing + end + + let subBinaryExprOperand parentOperator childOperator = + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence childOperator in + precParent > precChild || + (precParent == precChild && + not (ParsetreeViewer.flattenableOperators parentOperator childOperator)) || + (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) + (parentOperator = "||" && childOperator = "&&") + + let rhsBinaryExprOperand parentOperator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply( + {pexp_attributes = []; + pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, + [_, _left; _, _right] + ) when ParsetreeViewer.isBinaryOperator operator && + not (operatorLoc.loc_ghost && operator = "^") -> + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent == precChild + | _ -> false + + let flattenOperandRhs parentOperator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, + [_, _left; _, _right] + ) when ParsetreeViewer.isBinaryOperator operator && + not (operatorLoc.loc_ghost && operator = "^") -> + let precParent = ParsetreeViewer.operatorPrecedence parentOperator in + let precChild = ParsetreeViewer.operatorPrecedence operator in + precParent >= precChild || rhs.pexp_attributes <> [] + | Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ) -> false + | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_setfield _ + | Pexp_constraint _ -> true + | _ when ParsetreeViewer.isTernaryExpr rhs -> true + | _ -> false + + let lazyOrAssertExprRhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let isNegativeConstant constant = + let isNeg txt = + let len = String.length txt in + len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' + in + match constant with + | Parsetree.Pconst_integer (i, _) | Pconst_float (i, _) when isNeg i -> true + | _ -> false + + let fieldExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = attrs} when + begin match ParsetreeViewer.filterParsingAttrs attrs with + | _::_ -> true + | [] -> false + end + -> Parenthesized + | expr when + ParsetreeViewer.isBinaryExpression expr || + ParsetreeViewer.isUnaryExpression expr + -> Parenthesized + | {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constant c } when isNegativeConstant c -> Parenthesized + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing + | {pexp_desc = + Pexp_lazy _ + | Pexp_assert _ + | Pexp_extension _ (* %extension.x vs (%extension).x *) + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_function _ + | Pexp_constraint _ + | Pexp_setfield _ + | Pexp_match _ + | Pexp_try _ + | Pexp_while _ + | Pexp_for _ + | Pexp_ifthenelse _ + } -> Parenthesized + | _ -> Nothing + end + + let setFieldExprRhs expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | _ -> Nothing + end + + let ternaryOperand expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + )} -> Nothing + | {pexp_desc = Pexp_constraint _ } -> Parenthesized + | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> + let (_attrsOnArrow, _parameters, returnExpr) = ParsetreeViewer.funExpr expr in + begin match returnExpr.pexp_desc with + | Pexp_constraint _ -> Parenthesized + | _ -> Nothing + end + | _ -> Nothing + end + + let startsWithMinus txt = + let len = String.length txt in + if len == 0 then + false + else + let s = (String.get [@doesNotRaise]) txt 0 in + s = '-' + + let jsxPropExpr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ + | Pexp_sequence _ + | Pexp_letexception _ + | Pexp_letmodule _ + | Pexp_open _ -> Nothing + | _ -> + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + begin match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []} + when startsWithMinus x -> Parenthesized + | {Parsetree.pexp_desc = + Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | + Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | + Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | + Pexp_let _ | Pexp_tuple _; + pexp_attributes = [] + } -> Nothing + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ); pexp_attributes = []} -> Nothing + | _ -> Parenthesized + end + end + + let jsxChildExpr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ + | Pexp_sequence _ + | Pexp_letexception _ + | Pexp_letmodule _ + | Pexp_open _ -> Nothing + | _ -> + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + begin match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | _ -> + begin match expr with + | {Parsetree.pexp_desc = Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = [] + } when startsWithMinus x -> Parenthesized + | {Parsetree.pexp_desc = + Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | + Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | + Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | + Pexp_let _; + pexp_attributes = [] + } -> Nothing + | {Parsetree.pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ); pexp_attributes = []} -> Nothing + | expr when ParsetreeViewer.isJsxExpression expr -> Nothing + | _ -> Parenthesized + end + end + + let binaryExpr expr = + let optBraces, _ = ParsetreeViewer.processBracesAttr expr in + match optBraces with + | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) + | None -> + begin match expr with + | {Parsetree.pexp_attributes = _::_} as expr + when ParsetreeViewer.isBinaryExpression expr -> Parenthesized + | _ -> Nothing + end + + let modTypeFunctorReturn modType = match modType with + | {Parsetree.pmty_desc = Pmty_with _} -> true + | _ -> false + + (* Add parens for readability: + module type Functor = SetLike => Set with type t = A.t + This is actually: + module type Functor = (SetLike => Set) with type t = A.t + *) + let modTypeWithOperand modType = match modType with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false + + let modExprFunctorConstraint modType = match modType with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false + + let bracedExpr expr = match expr.Parsetree.pexp_desc with + | Pexp_constraint ( + {pexp_desc = Pexp_pack _}, + {ptyp_desc = Ptyp_package _} + ) -> false + | Pexp_constraint _ -> true + | _ -> false + + let includeModExpr modExpr = match modExpr.Parsetree.pmod_desc with + | Parsetree.Pmod_constraint _ -> true + | _ -> false + +let arrowReturnTypExpr typExpr = match typExpr.Parsetree.ptyp_desc with + | Parsetree.Ptyp_arrow _ -> true + | _ -> false + +let patternRecordRowRhs (pattern : Parsetree.pattern) = + match pattern.ppat_desc with + | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) -> false + | Ppat_constraint _ -> true + | _ -> false diff --git a/analysis/src/vendor/res_outcome_printer/res_parens.mli b/analysis/src/vendor/res_outcome_printer/res_parens.mli new file mode 100644 index 000000000..095b56308 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parens.mli @@ -0,0 +1,36 @@ +type kind = Parenthesized | Braced of Location.t | Nothing + +val expr: Parsetree.expression -> kind +val structureExpr: Parsetree.expression -> kind + +val unaryExprOperand: Parsetree.expression -> kind + +val binaryExprOperand: isLhs:bool -> Parsetree.expression -> kind +val subBinaryExprOperand: string -> string -> bool +val rhsBinaryExprOperand: string -> Parsetree.expression -> bool +val flattenOperandRhs: string -> Parsetree.expression -> bool + +val lazyOrAssertExprRhs: Parsetree.expression -> kind + +val fieldExpr: Parsetree.expression -> kind + +val setFieldExprRhs: Parsetree.expression -> kind + +val ternaryOperand: Parsetree.expression -> kind + +val jsxPropExpr: Parsetree.expression -> kind +val jsxChildExpr: Parsetree.expression -> kind + +val binaryExpr: Parsetree.expression -> kind +val modTypeFunctorReturn: Parsetree.module_type -> bool +val modTypeWithOperand: Parsetree.module_type -> bool +val modExprFunctorConstraint: Parsetree.module_type -> bool + +val bracedExpr: Parsetree.expression -> bool +val callExpr: Parsetree.expression -> kind + +val includeModExpr : Parsetree.module_expr -> bool + +val arrowReturnTypExpr: Parsetree.core_type -> bool + +val patternRecordRowRhs: Parsetree.pattern -> bool diff --git a/analysis/src/vendor/res_outcome_printer/res_parser.ml b/analysis/src/vendor/res_outcome_printer/res_parser.ml new file mode 100644 index 000000000..6aa63f97f --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parser.ml @@ -0,0 +1,163 @@ +module Scanner = Res_scanner +module Diagnostics = Res_diagnostics +module Token = Res_token +module Grammar = Res_grammar +module Reporting = Res_reporting + +module Comment = Res_comment + +type mode = ParseForTypeChecker | Default + +type regionStatus = Report | Silent + +type t = { + mode: mode; + mutable scanner: Scanner.t; + mutable token: Token.t; + mutable startPos: Lexing.position; + mutable endPos: Lexing.position; + mutable prevEndPos: Lexing.position; + mutable breadcrumbs: (Grammar.t * Lexing.position) list; + mutable errors: Reporting.parseError list; + mutable diagnostics: Diagnostics.t list; + mutable comments: Comment.t list; + mutable regions: regionStatus ref list; +} + +let err ?startPos ?endPos p error = + match p.regions with + | {contents = Report} as region::_ -> + let d = + Diagnostics.make + ~startPos:(match startPos with | Some pos -> pos | None -> p.startPos) + ~endPos:(match endPos with | Some pos -> pos | None -> p.endPos) + error + in ( + p.diagnostics <- d::p.diagnostics; + region := Silent + ) + | _ -> () + +let beginRegion p = + p.regions <- ref Report :: p.regions +let endRegion p = + match p.regions with + | [] -> () + | _::rest -> p.regions <- rest + +(* Advance to the next non-comment token and store any encountered comment +* in the parser's state. Every comment contains the end position of its +* previous token to facilite comment interleaving *) +let rec next ?prevEndPos p = + let prevEndPos = match prevEndPos with Some pos -> pos | None -> p.endPos in + let (startPos, endPos, token) = Scanner.scan p.scanner in + match token with + | Comment c -> + Comment.setPrevTokEndPos c p.endPos; + p.comments <- c::p.comments; + p.prevEndPos <- p.endPos; + p.endPos <- endPos; + next ~prevEndPos p + | _ -> + p.token <- token; + (* p.prevEndPos <- prevEndPos; *) + p.prevEndPos <- prevEndPos; + p.startPos <- startPos; + p.endPos <- endPos + +let nextTemplateLiteralToken p = + let (startPos, endPos, token) = Scanner.scanTemplateLiteralToken p.scanner in + p.token <- token; + p.prevEndPos <- p.endPos; + p.startPos <- startPos; + p.endPos <- endPos + +let checkProgress ~prevEndPos ~result p = + if p.endPos == prevEndPos + then None + else Some result + +let make ?(mode=ParseForTypeChecker) src filename = + let scanner = Scanner.make ~filename src in + let parserState = { + mode; + scanner; + token = Token.Eof; + startPos = Lexing.dummy_pos; + prevEndPos = Lexing.dummy_pos; + endPos = Lexing.dummy_pos; + breadcrumbs = []; + errors = []; + diagnostics = []; + comments = []; + regions = [ref Report]; + } in + parserState.scanner.err <- (fun ~startPos ~endPos error -> + let diagnostic = Diagnostics.make + ~startPos + ~endPos + error + in + parserState.diagnostics <- diagnostic::parserState.diagnostics + ); + next parserState; + parserState + +let leaveBreadcrumb p circumstance = + let crumb = (circumstance, p.startPos) in + p.breadcrumbs <- crumb::p.breadcrumbs + +let eatBreadcrumb p = + match p.breadcrumbs with + | [] -> () + | _::crumbs -> p.breadcrumbs <- crumbs + +let optional p token = + if p.token = token then + let () = next p in true + else + false + +let expect ?grammar token p = + if p.token = token then + next p + else + let error = Diagnostics.expected ?grammar p.prevEndPos token in + err ~startPos:p.prevEndPos p error + +(* Don't use immutable copies here, it trashes certain heuristics + * in the ocaml compiler, resulting in massive slowdowns of the parser *) +let lookahead p callback = + let err = p.scanner.err in + let ch = p.scanner.ch in + let offset = p.scanner.offset in + let lineOffset = p.scanner.lineOffset in + let lnum = p.scanner.lnum in + let mode = p.scanner.mode in + let token = p.token in + let startPos = p.startPos in + let endPos = p.endPos in + let prevEndPos = p.prevEndPos in + let breadcrumbs = p.breadcrumbs in + let errors = p.errors in + let diagnostics = p.diagnostics in + let comments = p.comments in + + let res = callback p in + + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.lineOffset <- lineOffset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.startPos <- startPos; + p.endPos <- endPos; + p.prevEndPos <- prevEndPos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + + res diff --git a/analysis/src/vendor/res_outcome_printer/res_parser.mli b/analysis/src/vendor/res_outcome_printer/res_parser.mli new file mode 100644 index 000000000..80a1c6394 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parser.mli @@ -0,0 +1,48 @@ +module Scanner = Res_scanner +module Token = Res_token +module Grammar = Res_grammar +module Reporting = Res_reporting +module Diagnostics = Res_diagnostics +module Comment = Res_comment + +type mode = ParseForTypeChecker | Default + +type regionStatus = Report | Silent + +type t = { + mode: mode; + mutable scanner: Scanner.t; + mutable token: Token.t; + mutable startPos: Lexing.position; + mutable endPos: Lexing.position; + mutable prevEndPos: Lexing.position; + mutable breadcrumbs: (Grammar.t * Lexing.position) list; + mutable errors: Reporting.parseError list; + mutable diagnostics: Diagnostics.t list; + mutable comments: Comment.t list; + mutable regions: regionStatus ref list; +} + +val make: ?mode:mode -> string -> string -> t + +val expect: ?grammar:Grammar.t -> Token.t -> t -> unit +val optional: t -> Token.t -> bool +val next: ?prevEndPos:Lexing.position -> t -> unit +val nextTemplateLiteralToken: t -> unit +val lookahead: t -> (t -> 'a) -> 'a +val err: + ?startPos:Lexing.position -> + ?endPos:Lexing.position -> + t -> Diagnostics.category -> unit + +val leaveBreadcrumb: t -> Grammar.t -> unit +val eatBreadcrumb: t -> unit + +val beginRegion: t -> unit +val endRegion: t -> unit + +val checkProgress: + prevEndPos: Lexing.position -> + result: 'a -> + t -> + 'a option diff --git a/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.ml b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.ml new file mode 100644 index 000000000..7c25e3aaa --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.ml @@ -0,0 +1,576 @@ +open Parsetree + +let arrowType ct = + let rec process attrsBefore acc typ = match typ with + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = []} -> + let arg = ([], lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = [({txt ="bs"}, _) ] as attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> + let args = List.rev acc in + (attrsBefore, args, returnType) + | {ptyp_desc = Ptyp_arrow ((Labelled _ | Optional _) as lbl, typ1, typ2); ptyp_attributes = attrs} -> + let arg = (attrs, lbl, typ1) in + process attrsBefore (arg::acc) typ2 + | typ -> + (attrsBefore, List.rev acc, typ) + in + begin match ct with + | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> + process attrs [] {typ with ptyp_attributes = []} + | typ -> process [] [] typ + end + +let functorType modtype = + let rec process acc modtype = match modtype with + | {pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs} -> + let arg = (attrs, lbl, argType) in + process (arg::acc) returnType + | modType -> + (List.rev acc, modType) + in + process [] modtype + +let processUncurriedAttribute attrs = + let rec process uncurriedSpotted acc attrs = + match attrs with + | [] -> (uncurriedSpotted, List.rev acc) + | ({Location.txt = "bs"}, _)::rest -> process true acc rest + | attr::rest -> process uncurriedSpotted (attr::acc) rest + in + process false [] attrs + +let collectListExpressions expr = + let rec collect acc expr = match expr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + (List.rev acc, None) + | Pexp_construct ( + {txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple (hd::[tail])} + ) -> + collect (hd::acc) tail + | _ -> + (List.rev acc, Some expr) + in + collect [] expr + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +let rewriteUnderscoreApply expr = + match expr.pexp_desc with + | Pexp_fun ( + Nolabel, + None, + {ppat_desc = Ppat_var {txt="__x"}}, + ({pexp_desc = Pexp_apply (callExpr, args)} as e) + ) -> + let newArgs = List.map (fun arg -> + match arg with + | ( + lbl, + ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} as argExpr) + ) -> + (lbl, {argExpr with pexp_desc = Pexp_ident ({lid with txt = Longident.Lident "_"})}) + | arg -> arg + ) args in + {e with pexp_desc = Pexp_apply (callExpr, newArgs)} + | _ -> expr + +type funParamKind = + | Parameter of { + attrs: Parsetree.attributes; + lbl: Asttypes.arg_label; + defaultExpr: Parsetree.expression option; + pat: Parsetree.pattern; + } + | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} + +let funExpr expr = + (* Turns (type t, type u, type z) into "type t u z" *) + let rec collectNewTypes acc returnExpr = + match returnExpr with + | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} -> + collectNewTypes (stringLoc::acc) returnExpr + | returnExpr -> + (List.rev acc, returnExpr) + in + let rec collect attrsBefore acc expr = match expr with + | {pexp_desc = Pexp_fun ( + Nolabel, + None, + {ppat_desc = Ppat_var {txt="__x"}}, + {pexp_desc = Pexp_apply _} + )} -> + (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []} -> + let parameter = Parameter { + attrs = []; + lbl = lbl; + defaultExpr = defaultExpr; + pat = pattern; + } in + collect attrsBefore (parameter::acc) returnExpr + | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> + let (stringLocs, returnExpr) = collectNewTypes [stringLoc] rest in + let param = NewTypes {attrs; locs = stringLocs} in + collect attrsBefore (param::acc) returnExpr + | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = [({txt = "bs"}, _)] as attrs} -> + let parameter = Parameter { + attrs = attrs; + lbl = lbl; + defaultExpr = defaultExpr; + pat = pattern; + } in + collect attrsBefore (parameter::acc) returnExpr + | { + pexp_desc = Pexp_fun ((Labelled _ | Optional _) as lbl, defaultExpr, pattern, returnExpr); + pexp_attributes = attrs + } -> + let parameter = Parameter { + attrs = attrs; + lbl = lbl; + defaultExpr = defaultExpr; + pat = pattern; + } in + collect attrsBefore (parameter::acc) returnExpr + | expr -> + (attrsBefore, List.rev acc, expr) + in + begin match expr with + | {pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs} as expr -> + collect attrs [] {expr with pexp_attributes = []} + | expr -> collect [] [] expr + end + +let processBracesAttr expr = + match expr.pexp_attributes with + | (({txt = "ns.braces"}, _) as attr)::attrs -> + (Some attr, {expr with pexp_attributes = attrs}) + | _ -> + (None, expr) + +let filterParsingAttrs attrs = + List.filter (fun attr -> + match attr with + | ({Location.txt = ("ns.ternary" | "ns.braces" | "bs" | "ns.iflet" | "ns.namedArgLoc")}, _) -> false + | _ -> true + ) attrs + +let isBlockExpr expr = + match expr.pexp_desc with + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_let _ + | Pexp_open _ + | Pexp_sequence _ -> true + | _ -> false + +let isBracedExpr expr = + match processBracesAttr expr with + | (Some _, _) -> true + | _ -> false + +let isMultilineText txt = + let len = String.length txt in + let rec check i= + if i >= len then false + else + let c = String.unsafe_get txt i in + match c with + | '\010' | '\013' -> true + | '\\' -> + if (i + 2) = len then false + else + check (i + 2) + | _ -> check (i + 1) + in + check 0 + +let isHuggableExpression expr = + match expr.pexp_desc with + | Pexp_array _ + | Pexp_tuple _ + | Pexp_constant (Pconst_string (_, Some _)) + | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) + | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_record _ -> true + | _ when isBlockExpr expr -> true + | _ when isBracedExpr expr -> true + | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true + | _ -> false + +let isHuggableRhs expr = + match expr.pexp_desc with + | Pexp_array _ + | Pexp_tuple _ + | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) + | Pexp_extension ({txt = "bs.obj" | "obj"}, _) + | Pexp_record _ -> true + | _ when isBracedExpr expr -> true + | _ -> false + +let isHuggablePattern pattern = + match pattern.ppat_desc with + | Ppat_array _ + | Ppat_tuple _ + | Ppat_record _ + | Ppat_variant _ + | Ppat_construct _ -> true + | _ -> false + +let operatorPrecedence operator = match operator with + | ":=" -> 1 + | "||" -> 2 + | "&&" -> 3 + | "=" | "==" | "<" | ">" | "!=" | "<>" | "!==" | "<=" | ">=" | "|>" -> 4 + | "+" | "+." | "-" | "-." | "^" -> 5 + | "*" | "*." | "/" | "/." -> 6 + | "**" -> 7 + | "#" | "##" | "|." -> 8 + | _ -> 0 + +let isUnaryOperator operator = match operator with + | "~+" | "~+." | "~-" | "~-." | "not" -> true + | _ -> false + +let isUnaryExpression expr = match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, _arg] + ) when isUnaryOperator operator -> true + | _ -> false + +(* TODO: tweak this to check for ghost ^ as template literal *) +let isBinaryOperator operator = match operator with + | ":=" + | "||" + | "&&" + | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" + | "+" | "+." | "-" | "-." | "^" + | "*" | "*." | "/" | "/." + | "**" + | "|." | "<>" -> true + | _ -> false + +let isBinaryExpression expr = match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}}, + [(Nolabel, _operand1); (Nolabel, _operand2)] + ) when isBinaryOperator operator && + not (operatorLoc.loc_ghost && operator = "^") (* template literal *) + -> true + | _ -> false + +let isEqualityOperator operator = match operator with + | "=" | "==" | "<>" | "!=" -> true + | _ -> false + +let flattenableOperators parentOperator childOperator = + let precParent = operatorPrecedence parentOperator in + let precChild = operatorPrecedence childOperator in + if precParent == precChild then + not ( + isEqualityOperator parentOperator && + isEqualityOperator childOperator + ) + else + false + +let rec hasIfLetAttribute attrs = + match attrs with + | [] -> false + | ({Location.txt="ns.iflet"},_)::_ -> true + | _::attrs -> hasIfLetAttribute attrs + +let isIfLetExpr expr = match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_match _ + } when hasIfLetAttribute attrs -> true + | _ -> false + +let hasAttributes attrs = + List.exists (fun attr -> match attr with + | ({Location.txt = "bs" | "ns.ternary" | "ns.braces" | "ns.iflet"}, _) -> false + (* Remove the fragile pattern warning for iflet expressions *) + | ({Location.txt="warning"}, PStr [{ + pstr_desc = Pstr_eval ({ + pexp_desc = Pexp_constant ( + Pconst_string ("-4", None) + ) + }, _) + }]) -> not (hasIfLetAttribute attrs) + | _ -> true + ) attrs + +let isArrayAccess expr = match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [Nolabel, _parentExpr; Nolabel, _memberExpr] + ) -> true + | _ -> false + + +type ifConditionKind = +| If of Parsetree.expression +| IfLet of Parsetree.pattern * Parsetree.expression + +let collectIfExpressions expr = + let rec collect acc expr = match expr.pexp_desc with + | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> + collect ((If(ifExpr), thenExpr)::acc) elseExpr + | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> + let ifs = List.rev ((If(ifExpr), thenExpr)::acc) in + (ifs, elseExpr) + | Pexp_match (condition, [{ + pc_lhs = pattern; + pc_guard = None; + pc_rhs = thenExpr; + }; { + pc_rhs = {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + }]) when isIfLetExpr expr -> + let ifs = List.rev ((IfLet(pattern, condition), thenExpr)::acc) in + (ifs, None) + | Pexp_match (condition, [{ + pc_lhs = pattern; + pc_guard = None; + pc_rhs = thenExpr; + }; { + pc_rhs = elseExpr; + }]) when isIfLetExpr expr -> + collect ((IfLet(pattern, condition), thenExpr)::acc) elseExpr + | _ -> + (List.rev acc, Some expr) + in + collect [] expr + +let rec hasTernaryAttribute attrs = + match attrs with + | [] -> false + | ({Location.txt="ns.ternary"},_)::_ -> true + | _::attrs -> hasTernaryAttribute attrs + +let isTernaryExpr expr = match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_ifthenelse _ + } when hasTernaryAttribute attrs -> true + | _ -> false + +let collectTernaryParts expr = + let rec collect acc expr = match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_ifthenelse (condition, consequent, Some(alternate)) + } when hasTernaryAttribute attrs -> collect ((condition, consequent)::acc) alternate + | alternate -> (List.rev acc, alternate) + in + collect [] expr + +let parametersShouldHug parameters = match parameters with + | [Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = pat + }] when isHuggablePattern pat -> true + | _ -> false + +let filterTernaryAttributes attrs = + List.filter (fun attr -> match attr with + |({Location.txt="ns.ternary"},_) -> false + | _ -> true + ) attrs + +let filterFragileMatchAttributes attrs = + List.filter (fun attr -> match attr with + | ({Location.txt="warning"}, PStr [{ + pstr_desc = Pstr_eval ({ + pexp_desc = Pexp_constant ( + Pconst_string ("-4", _) + ) + }, _) + }]) -> false + | _ -> true + ) attrs + +let isJsxExpression expr = + let rec loop attrs = + match attrs with + | [] -> false + | ({Location.txt = "JSX"}, _)::_ -> true + | _::attrs -> loop attrs + in + match expr.pexp_desc with + | Pexp_apply _ -> + loop expr.Parsetree.pexp_attributes + | _ -> false + +let hasJsxAttribute attributes = + let rec loop attrs = + match attrs with + | [] -> false + | ({Location.txt = "JSX"}, _)::_ -> true + | _::attrs -> loop attrs + in + loop attributes + +let shouldIndentBinaryExpr expr = + let samePrecedenceSubExpression operator subExpression = + match subExpression with + | {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, + [Nolabel, _lhs; Nolabel, _rhs] + )} when isBinaryOperator subOperator -> + flattenableOperators operator subOperator + | _ -> true + in + match expr with + | {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, lhs; Nolabel, _rhs] + )} when isBinaryOperator operator -> + isEqualityOperator operator || + not (samePrecedenceSubExpression operator lhs) || + operator = ":=" + | _ -> false + +let shouldInlineRhsBinaryExpr rhs = match rhs.pexp_desc with + | Parsetree.Pexp_constant _ + | Pexp_let _ + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_sequence _ + | Pexp_open _ + | Pexp_ifthenelse _ + | Pexp_for _ + | Pexp_while _ + | Pexp_try _ + | Pexp_array _ + | Pexp_record _ -> true + | _ -> false + +let filterPrinteableAttributes attrs = + List.filter (fun attr -> match attr with + | ({Location.txt="bs" | "ns.ternary" | "ns.iflet" | "JSX"}, _) -> false + | _ -> true + ) attrs + +let partitionPrinteableAttributes attrs = + List.partition (fun attr -> match attr with + | ({Location.txt="bs" | "ns.ternary" | "ns.iflet" | "JSX"}, _) -> false + | _ -> true + ) attrs + +let requiresSpecialCallbackPrintingLastArg args = + let rec loop args = match args with + | [] -> false + | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false + | _::rest -> loop rest + in + loop args + +let requiresSpecialCallbackPrintingFirstArg args = + let rec loop args = match args with + | [] -> true + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false + | _::rest -> loop rest + in + match args with + | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false + | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::rest -> loop rest + | _ -> false + +let modExprApply modExpr = + let rec loop acc modExpr = match modExpr with + | {pmod_desc = Pmod_apply (next, arg)} -> + loop (arg::acc) next + | _ -> (acc, modExpr) + in + loop [] modExpr + +let modExprFunctor modExpr = + let rec loop acc modExpr = match modExpr with + | {pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} -> + let param = (attrs, lbl, modType) in + loop (param::acc) returnModExpr + | returnModExpr -> + (List.rev acc, returnModExpr) + in + loop [] modExpr + +let rec collectPatternsFromListConstruct acc pattern = + let open Parsetree in + match pattern.ppat_desc with + | Ppat_construct( + {txt = Longident.Lident "::"}, + Some {ppat_desc=Ppat_tuple (pat::rest::[])} + ) -> + collectPatternsFromListConstruct (pat::acc) rest + | _ -> List.rev acc, pattern + +(* Simple heuristic to detect template literal sugar: + * `${user.name} lastName` parses internally as user.name ++ ` lastName`. + * The thing is: the ++ operator (parsed as `^`) will always have a ghost loc. + * A ghost loc is only produced by our parser. + * Hence, if we have that ghost operator, we know for sure it's a template literal. *) +let isTemplateLiteral expr = + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, + [Nolabel, _; Nolabel, _] + ) when loc.loc_ghost -> true + | _ -> false + +(* Blue | Red | Green -> [Blue; Red; Green] *) +let collectOrPatternChain pat = + let rec loop pattern chain = + match pattern.ppat_desc with + | Ppat_or (left, right) -> loop left (right::chain) + | _ -> pattern::chain + in + loop pat [] + +let isSinglePipeExpr expr = + (* handles: + * x + * ->Js.Dict.get("wm-property") + * ->Option.flatMap(Js.Json.decodeString) + * ->Option.flatMap(x => + * switch x { + * | "like-of" => Some(#like) + * | "repost-of" => Some(#repost) + * | _ => None + * } + * ) + *) + let isPipeExpr expr = match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, + [(Nolabel, _operand1); (Nolabel, _operand2)] + ) -> true + | _ -> false + in + match expr.pexp_desc with + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, + [(Nolabel, operand1); (Nolabel, _operand2)] + ) when not (isPipeExpr operand1) -> true + | _ -> false + +let isUnderscoreApplySugar expr = + match expr.pexp_desc with + | Pexp_fun ( + Nolabel, + None, + {ppat_desc = Ppat_var {txt="__x"}}, + {pexp_desc = Pexp_apply _} + ) -> true + | _ -> false + +let isRewrittenUnderscoreApplySugar expr = + match expr.pexp_desc with + | Pexp_ident {txt = Longident.Lident "_"} -> true + | _ -> false diff --git a/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.mli b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.mli new file mode 100644 index 000000000..f83ea02f4 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_parsetree_viewer.mli @@ -0,0 +1,132 @@ +(* Restructures a nested tree of arrow types into its args & returnType + * The parsetree contains: a => b => c => d, for printing purposes + * we restructure the tree into (a, b, c) and its returnType d *) + val arrowType: Parsetree.core_type -> + Parsetree.attributes * + (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list * + Parsetree.core_type + +val functorType: Parsetree.module_type -> + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * + Parsetree.module_type + +(* filters @bs out of the provided attributes *) +val processUncurriedAttribute: Parsetree.attributes -> bool * Parsetree.attributes + +type ifConditionKind = + | If of Parsetree.expression + | IfLet of Parsetree.pattern * Parsetree.expression + +(* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } +* The purpose of this function is to flatten nested ifs into one sequence. +* Basically compute: ([if, else if, else if, else if], else) *) +val collectIfExpressions: + Parsetree.expression -> + (ifConditionKind * Parsetree.expression) list * Parsetree.expression option + +val collectListExpressions: + Parsetree.expression -> (Parsetree.expression list * Parsetree.expression option) + +type funParamKind = + | Parameter of { + attrs: Parsetree.attributes; + lbl: Asttypes.arg_label; + defaultExpr: Parsetree.expression option; + pat: Parsetree.pattern; + } + | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} + +val funExpr: + Parsetree.expression -> + Parsetree.attributes * + funParamKind list * + Parsetree.expression + +(* example: +* `makeCoordinate({ +* x: 1, +* y: 2, +* })` +* Notice howe `({` and `})` "hug" or stick to each other *) +val isHuggableExpression: Parsetree.expression -> bool + +val isHuggablePattern: Parsetree.pattern -> bool + +val isHuggableRhs: Parsetree.expression -> bool + +val operatorPrecedence: string -> int + +val isUnaryExpression: Parsetree.expression -> bool +val isBinaryOperator: string -> bool +val isBinaryExpression: Parsetree.expression -> bool + +val flattenableOperators: string -> string -> bool + +val hasAttributes: Parsetree.attributes -> bool + +val isArrayAccess: Parsetree.expression -> bool +val isTernaryExpr: Parsetree.expression -> bool +val isIfLetExpr: Parsetree.expression -> bool + +val collectTernaryParts: Parsetree.expression -> ((Parsetree.expression * Parsetree.expression) list * Parsetree.expression) + +val parametersShouldHug: + funParamKind list -> bool + +val filterTernaryAttributes: Parsetree.attributes -> Parsetree.attributes +val filterFragileMatchAttributes: Parsetree.attributes -> Parsetree.attributes + +val isJsxExpression: Parsetree.expression -> bool +val hasJsxAttribute: Parsetree.attributes -> bool + +val shouldIndentBinaryExpr: Parsetree.expression -> bool +val shouldInlineRhsBinaryExpr: Parsetree.expression -> bool +val filterPrinteableAttributes: Parsetree.attributes -> Parsetree.attributes +val partitionPrinteableAttributes: Parsetree.attributes -> (Parsetree.attributes * Parsetree.attributes) + +val requiresSpecialCallbackPrintingLastArg: (Asttypes.arg_label * Parsetree.expression) list -> bool +val requiresSpecialCallbackPrintingFirstArg: (Asttypes.arg_label * Parsetree.expression) list -> bool + +val modExprApply : Parsetree.module_expr -> ( + Parsetree.module_expr list * Parsetree.module_expr +) + +(* Collection of utilities to view the ast in a more a convenient form, + * allowing for easier processing. + * Example: given a ptyp_arrow type, what are its arguments and what is the + * returnType? *) + + +val modExprFunctor : Parsetree.module_expr -> ( + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * + Parsetree.module_expr +) + +val collectPatternsFromListConstruct: + Parsetree.pattern list -> Parsetree.pattern -> + (Parsetree.pattern list * Parsetree.pattern) + +val isBlockExpr : Parsetree.expression -> bool + +val isTemplateLiteral: Parsetree.expression -> bool + +val collectOrPatternChain: + Parsetree.pattern -> Parsetree.pattern list + +val processBracesAttr : Parsetree.expression -> (Parsetree.attribute option * Parsetree.expression) + +val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes + +val isBracedExpr : Parsetree.expression -> bool + +val isSinglePipeExpr : Parsetree.expression -> bool + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +val rewriteUnderscoreApply: Parsetree.expression -> Parsetree.expression + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +val isUnderscoreApplySugar: Parsetree.expression -> bool + +val hasIfLetAttribute: Parsetree.attributes -> bool + +val isRewrittenUnderscoreApplySugar: Parsetree.expression -> bool diff --git a/analysis/src/vendor/res_outcome_printer/res_printer.ml b/analysis/src/vendor/res_outcome_printer/res_printer.ml new file mode 100644 index 000000000..edd92d326 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_printer.ml @@ -0,0 +1,5256 @@ +module Doc = Res_doc +module CommentTable = Res_comments_table +module Comment = Res_comment +module Token = Res_token +module Parens = Res_parens +module ParsetreeViewer = Res_parsetree_viewer + +type callbackStyle = + (* regular arrow function, example: `let f = x => x + 1` *) + | NoCallback + (* `Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument))` *) + | FitsOnOneLine + (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => + * MyModuleBlah.toList(argument) + * ) + *) + | ArgumentsFitOnOneLine + +(* Since compiler version 8.3, the bs. prefix is no longer needed *) +(* Synced from + https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_external_process.ml#L291-L367 *) +let convertBsExternalAttribute = function + | "bs.as" -> "as" + | "bs.deriving" -> "deriving" + | "bs.get" -> "get" + | "bs.get_index" -> "get_index" + | "bs.ignore" -> "ignore" + | "bs.inline" -> "inline" + | "bs.int" -> "int" + | "bs.meth" -> "meth" + | "bs.module" -> "module" + | "bs.new" -> "new" + | "bs.obj" -> "obj" + | "bs.optional" -> "optional" + | "bs.return" -> "return" + | "bs.send" -> "send" + | "bs.scope" -> "scope" + | "bs.set" -> "set" + | "bs.set_index" -> "set_index" + | "bs.splice" | "bs.variadic" -> "variadic" + | "bs.string" -> "string" + | "bs.this" -> "this" + | "bs.uncurry" -> "uncurry" + | "bs.unwrap" -> "unwrap" + | "bs.val" -> "val" + (* bs.send.pipe shouldn't be transformed *) + | txt -> txt + +(* These haven't been needed for a long time now *) +(* Synced from + https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_exp_extension.ml *) +let convertBsExtension = function + | "bs.debugger" -> "debugger" + | "bs.external" -> "raw" + (* We should never see this one since we use the sugared object form, but still *) + | "bs.obj" -> "obj" + | "bs.raw" -> "raw" + | "bs.re" -> "re" + (* TODO: what about bs.time and bs.node? *) + | txt -> txt + +let addParens doc = + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + doc + ] + ); + Doc.softLine; + Doc.rparen; + ] + ) + +let addBraces doc = + Doc.group ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + doc; + ] + ); + Doc.softLine; + Doc.rbrace; + ] + ) + +let getFirstLeadingComment tbl loc = + match Hashtbl.find tbl.CommentTable.leading loc with + | comment::_ -> Some comment + | [] -> None + | exception Not_found -> None + +(* Checks if `loc` has a leading line comment, i.e. `// comment above`*) +let hasLeadingLineComment tbl loc = + match getFirstLeadingComment tbl loc with + | Some comment -> Comment.isSingleLineComment comment + | None -> false + +let hasCommentBelow tbl loc = + match Hashtbl.find tbl.CommentTable.trailing loc with + | comment::_ -> + let commentLoc = Comment.loc comment in + commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + | [] -> false + | exception Not_found -> false + +let printMultilineCommentContent txt = + (* Turns + * |* first line + * * second line + * * third line *| + * Into + * |* first line + * * second line + * * third line *| + * + * What makes a comment suitable for this kind of indentation? + * -> multiple lines + every line starts with a star + *) + let rec indentStars lines acc = + match lines with + | [] -> Doc.nil + | [lastLine] -> + let line = String.trim lastLine in + let doc = Doc.text (" " ^ line) in + let trailingSpace = if line = "" then Doc.nil else Doc.space in + List.rev (trailingSpace::doc::acc) |> Doc.concat + | line::lines -> + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indentStars lines (Doc.hardLine::doc::acc) + else + let trailingSpace = + let len = String.length txt in + if len > 0 && (String.unsafe_get txt (len - 1) = ' ') then + Doc.space + else Doc.nil + in + let content = Comment.trimSpaces txt in + Doc.concat [Doc.text content; trailingSpace] + in + let lines = String.split_on_char '\n' txt in + match lines with + | [] -> Doc.text "/* */" + | [line] -> Doc.concat [ + Doc.text "/* "; + Doc.text (Comment.trimSpaces line); + Doc.text " */"; + ] + | first::rest -> + let firstLine = Comment.trimSpaces first in + Doc.concat [ + Doc.text "/*"; + (match firstLine with + | "" | "*" -> Doc.nil + | _ -> Doc.space); + indentStars rest [Doc.hardLine; Doc.text firstLine]; + Doc.text "*/"; + ] + +let printTrailingComment (prevLoc: Location.t) (nodeLoc : Location.t) comment = + let singleLine = Comment.isSingleLineComment comment in + let content = + let txt = Comment.txt comment in + if singleLine then + Doc.text ("//" ^ txt) + else + printMultilineCommentContent txt + in + let diff = + let cmtStart = (Comment.loc comment).loc_start in + cmtStart.pos_lnum - prevLoc.loc_end.pos_lnum + in + let isBelow = + (Comment.loc comment).loc_start.pos_lnum > nodeLoc.loc_end.pos_lnum in + if diff > 0 || isBelow then + Doc.concat [ + Doc.breakParent; + Doc.lineSuffix( + (Doc.concat [Doc.hardLine; if diff > 1 then Doc.hardLine else Doc.nil; content]) + ) + ] + else if not singleLine then + Doc.concat [Doc.space; content] + else + Doc.lineSuffix (Doc.concat [Doc.space; content]) + +let printLeadingComment ?nextComment comment = + let singleLine = Comment.isSingleLineComment comment in + let content = + let txt = Comment.txt comment in + if singleLine then + Doc.text ("//" ^ txt) + else + printMultilineCommentContent txt + in + let separator = Doc.concat [ + if singleLine then Doc.concat [ + Doc.hardLine; + Doc.breakParent; + ] else Doc.nil; + (match nextComment with + | Some next -> + let nextLoc = Comment.loc next in + let currLoc = Comment.loc comment in + let diff = + nextLoc.Location.loc_start.pos_lnum - + currLoc.Location.loc_end.pos_lnum + in + let nextSingleLine = Comment.isSingleLineComment next in + if singleLine && nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else if singleLine && not nextSingleLine then + if diff > 1 then Doc.hardLine else Doc.nil + else + if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else if diff == 1 then Doc.hardLine + else + Doc.space + | None -> Doc.nil) + ] + in + Doc.concat [ + content; + separator; + ] + +let printCommentsInside cmtTbl loc = + let rec loop acc comments = + match comments with + | [] -> Doc.nil + | [comment] -> + let cmtDoc = printLeadingComment comment in + let doc = Doc.group ( + Doc.concat [ + Doc.concat (List.rev (cmtDoc::acc)); + ] + ) + in + doc + | comment::((nextComment::_comments) as rest) -> + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc::acc) rest + in + match Hashtbl.find cmtTbl.CommentTable.inside loc with + | exception Not_found -> Doc.nil + | comments -> + Hashtbl.remove cmtTbl.inside loc; + Doc.group ( + loop [] comments + ) + +let printLeadingComments node tbl loc = + let rec loop acc comments = + match comments with + | [] -> node + | [comment] -> + let cmtDoc = printLeadingComment comment in + let diff = + loc.Location.loc_start.pos_lnum - + (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.isSingleLineComment comment then + if diff > 1 then Doc.hardLine else Doc.nil + else if diff == 0 then + Doc.space + else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] + else + Doc.hardLine + in + let doc = Doc.group ( + Doc.concat [ + Doc.concat (List.rev (cmtDoc::acc)); + separator; + node + ] + ) + in + doc + | comment::((nextComment::_comments) as rest) -> + let cmtDoc = printLeadingComment ~nextComment comment in + loop (cmtDoc::acc) rest + in + match Hashtbl.find tbl loc with + | exception Not_found -> node + | comments -> + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments + +let printTrailingComments node tbl loc = + let rec loop prev acc comments = + match comments with + | [] -> Doc.concat (List.rev acc) + | comment::comments -> + let cmtDoc = printTrailingComment prev loc comment in + loop (Comment.loc comment) (cmtDoc::acc) comments + in + match Hashtbl.find tbl loc with + | exception Not_found -> node + | [] -> node + | (_first::_) as comments -> + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmtsDoc = loop loc [] comments in + Doc.concat [ + node; + cmtsDoc; + ] + +let printComments doc (tbl: CommentTable.t) loc = + let docWithLeadingComments = printLeadingComments doc tbl.leading loc in + printTrailingComments docWithLeadingComments tbl.trailing loc + +let printList ~getLoc ~nodes ~print ?(forceBreak=false) t = + let rec loop (prevLoc: Location.t) acc nodes = + match nodes with + | [] -> (prevLoc, Doc.concat (List.rev acc)) + | node::nodes -> + let loc = getLoc node in + let startPos = match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else + Doc.hardLine + in + let doc = printComments (print node t) t loc in + loop loc (doc::sep::acc) nodes + in + match nodes with + | [] -> Doc.nil + | node::nodes -> + let firstLoc = getLoc node in + let doc = printComments (print node t) t firstLoc in + let (lastLoc, docs) = loop firstLoc [doc] nodes in + let forceBreak = + forceBreak || + firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs + +let printListi ~getLoc ~nodes ~print ?(forceBreak=false) t = + let rec loop i (prevLoc: Location.t) acc nodes = + match nodes with + | [] -> (prevLoc, Doc.concat (List.rev acc)) + | node::nodes -> + let loc = getLoc node in + let startPos = match getFirstLeadingComment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hardLine; Doc.hardLine] + else + Doc.line + in + let doc = printComments (print node t i) t loc in + loop (i + 1) loc (doc::sep::acc) nodes + in + match nodes with + | [] -> Doc.nil + | node::nodes -> + let firstLoc = getLoc node in + let doc = printComments (print node t 0) t firstLoc in + let (lastLoc, docs) = loop 1 firstLoc [doc] nodes in + let forceBreak = + forceBreak || + firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak docs + +let rec printLongidentAux accu = function +| Longident.Lident s -> (Doc.text s) :: accu +| Ldot(lid, s) -> printLongidentAux ((Doc.text s) :: accu) lid +| Lapply(lid1, lid2) -> + let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in + (Doc.concat [d1; Doc.lparen; d2; Doc.rparen]) :: accu + +let printLongident = function +| Longident.Lident txt -> Doc.text txt +| lid -> Doc.join ~sep:Doc.dot (printLongidentAux [] lid) + +type identifierStyle = + | ExoticIdent + | NormalIdent + +let classifyIdentContent ?(allowUident=false) txt = + if Token.isKeywordTxt txt then + ExoticIdent + else + let len = String.length txt in + let rec loop i = + if i == len then NormalIdent + else if i == 0 then + match String.unsafe_get txt i with + | 'A'..'Z' when allowUident -> loop (i + 1) + | 'a'..'z' | '_' -> loop (i + 1) + | _ -> ExoticIdent + else + match String.unsafe_get txt i with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '\'' | '_' -> loop (i + 1) + | _ -> ExoticIdent + in + loop 0 + +let printIdentLike ?allowUident txt = + match classifyIdentContent ?allowUident txt with + | ExoticIdent -> Doc.concat [ + Doc.text "\\\""; + Doc.text txt; + Doc.text"\"" + ] + | NormalIdent -> Doc.text txt + +let rec unsafe_for_all_range s ~start ~finish p = + start > finish || + p (String.unsafe_get s start) && + unsafe_for_all_range s ~start:(start + 1) ~finish p + +let for_all_from s start p = + let len = String.length s in + unsafe_for_all_range s ~start ~finish:(len - 1) p + +(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) +let isValidNumericPolyvarNumber (x : string) = + let len = String.length x in + len > 0 && ( + let a = Char.code (String.unsafe_get x 0) in + a <= 57 && + (if len > 1 then + a > 48 && + for_all_from x 1 (function '0' .. '9' -> true | _ -> false) + else + a >= 48 ) + ) + +(* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) +let printPolyVarIdent txt = + (* numeric poly-vars don't need quotes: #644 *) + if isValidNumericPolyvarNumber txt then + Doc.text txt + else + match classifyIdentContent ~allowUident:true txt with + | ExoticIdent -> Doc.concat [ + Doc.text "\""; + Doc.text txt; + Doc.text"\"" + ] + | NormalIdent -> Doc.text txt + + +let printLident l = match l with + | Longident.Lident txt -> printIdentLike txt + | Longident.Ldot (path, txt) -> + let txts = Longident.flatten path in + Doc.concat [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + printIdentLike txt; + ] + | _ -> Doc.text("printLident: Longident.Lapply is not supported") + +let printLongidentLocation l cmtTbl = + let doc = printLongident l.Location.txt in + printComments doc cmtTbl l.loc + +(* Module.SubModule.x *) +let printLidentPath path cmtTbl = + let doc = printLident path.Location.txt in + printComments doc cmtTbl path.loc + +(* Module.SubModule.x or Module.SubModule.X *) +let printIdentPath path cmtTbl = + let doc = printLident path.Location.txt in + printComments doc cmtTbl path.loc + +let printStringLoc sloc cmtTbl = + let doc = printIdentLike sloc.Location.txt in + printComments doc cmtTbl sloc.loc + +let printStringContents txt = + let lines = String.split_on_char '\n' txt in + Doc.join ~sep:Doc.literalLine (List.map Doc.text lines) + +let printConstant c = match c with + | Parsetree.Pconst_integer (s, suffix) -> + begin match suffix with + | Some c -> Doc.text (s ^ (Char.escaped c)) + | None -> Doc.text s + end + | Pconst_string (txt, None) -> + Doc.concat [ + Doc.text "\""; + printStringContents txt; + Doc.text "\""; + ] + | Pconst_string (txt, Some prefix) -> + Doc.concat [ + if prefix = "js" then Doc.nil else Doc.text prefix; + Doc.text "`"; + printStringContents txt; + Doc.text "`"; + ] + | Pconst_float (s, _) -> Doc.text s + | Pconst_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") + +let rec printStructure (s : Parsetree.structure) t = + match s with + | [] -> printCommentsInside t Location.none + | structure -> + printList + ~getLoc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:printStructureItem + t + +and printStructureItem (si: Parsetree.structure_item) cmtTbl = + match si.pstr_desc with + | Pstr_value(rec_flag, valueBindings) -> + let recFlag = match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printValueBindings ~recFlag valueBindings cmtTbl + | Pstr_type(recFlag, typeDeclarations) -> + let recFlag = match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~recFlag typeDeclarations cmtTbl + | Pstr_primitive valueDescription -> + printValueDescription valueDescription cmtTbl + | Pstr_eval (expr, attrs) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.structureExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + printAttributes attrs cmtTbl; + exprDoc; + ] + | Pstr_attribute attr -> Doc.concat [ + Doc.text "@"; + printAttribute attr cmtTbl + ] + | Pstr_extension (extension, attrs) -> Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl]; + ] + | Pstr_include includeDeclaration -> + printIncludeDeclaration includeDeclaration cmtTbl + | Pstr_open openDescription -> + printOpenDescription openDescription cmtTbl + | Pstr_modtype modTypeDecl -> + printModuleTypeDeclaration modTypeDecl cmtTbl + | Pstr_module moduleBinding -> + printModuleBinding ~isRec:false moduleBinding cmtTbl 0 + | Pstr_recmodule moduleBindings -> + printListi + ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:moduleBindings + ~print:(printModuleBinding ~isRec:true) + cmtTbl + | Pstr_exception extensionConstructor -> + printExceptionDef extensionConstructor cmtTbl + | Pstr_typext typeExtension -> + printTypeExtension typeExtension cmtTbl + | Pstr_class _ | Pstr_class_type _ -> Doc.nil + +and printTypeExtension (te : Parsetree.type_extension) cmtTbl = + let prefix = Doc.text "type " in + let name = printLidentPath te.ptyext_path cmtTbl in + let typeParams = printTypeParams te.ptyext_params cmtTbl in + let extensionConstructors = + let ecs = te.ptyext_constructors in + let forceBreak = + match (ecs, List.rev ecs) with + | (first::_, last::_) -> + first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum || + first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + | _ -> false + in + let privateFlag = match te.ptyext_private with + | Asttypes.Private -> Doc.concat [ + Doc.text "private"; + Doc.line; + ] + | Public -> Doc.nil + in + let rows = + printListi + ~getLoc:(fun n -> n.Parsetree.pext_loc) + ~print:printExtensionConstructor + ~nodes: ecs + ~forceBreak + cmtTbl + in + Doc.breakableGroup ~forceBreak ( + Doc.indent ( + Doc.concat [ + Doc.line; + privateFlag; + rows; + (* Doc.join ~sep:Doc.line ( *) + (* List.mapi printExtensionConstructor ecs *) + (* ) *) + ] + ) + ) + in + Doc.group ( + Doc.concat [ + printAttributes ~loc: te.ptyext_path.loc te.ptyext_attributes cmtTbl; + prefix; + name; + typeParams; + Doc.text " +="; + extensionConstructors; + ] + ) + +and printModuleBinding ~isRec moduleBinding cmtTbl i = + let prefix = if i = 0 then + Doc.concat [ + Doc.text "module "; + if isRec then Doc.text "rec " else Doc.nil; + ] + else + Doc.text "and " + in + let (modExprDoc, modConstraintDoc) = + match moduleBinding.pmb_expr with + | {pmod_desc = Pmod_constraint (modExpr, modType)} -> + ( + printModExpr modExpr cmtTbl, + Doc.concat [ + Doc.text ": "; + printModType modType cmtTbl + ] + ) + | modExpr -> + (printModExpr modExpr cmtTbl, Doc.nil) + in + let modName = + let doc = Doc.text moduleBinding.pmb_name.Location.txt in + printComments doc cmtTbl moduleBinding.pmb_name.loc + in + let doc = Doc.concat [ + printAttributes + ~loc:moduleBinding.pmb_name.loc moduleBinding.pmb_attributes cmtTbl; + prefix; + modName; + modConstraintDoc; + Doc.text " = "; + modExprDoc; + ] in + printComments doc cmtTbl moduleBinding.pmb_loc + +and printModuleTypeDeclaration (modTypeDecl : Parsetree.module_type_declaration) cmtTbl = + let modName = + let doc = Doc.text modTypeDecl.pmtd_name.txt in + printComments doc cmtTbl modTypeDecl.pmtd_name.loc + in + Doc.concat [ + printAttributes modTypeDecl.pmtd_attributes cmtTbl; + Doc.text "module type "; + modName; + (match modTypeDecl.pmtd_type with + | None -> Doc.nil + | Some modType -> Doc.concat [ + Doc.text " = "; + printModType modType cmtTbl; + ]); + ] + +and printModType modType cmtTbl = + let modTypeDoc = match modType.pmty_desc with + | Parsetree.Pmty_ident longident -> + Doc.concat [ + printAttributes ~loc:longident.loc modType.pmty_attributes cmtTbl; + printLongidentLocation longident cmtTbl + ] + | Pmty_signature [] -> + let shouldBreak = + modType.pmty_loc.loc_start.pos_lnum < modType.pmty_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printCommentsInside cmtTbl modType.pmty_loc; + ]; + ); + Doc.softLine; + Doc.rbrace; + ] + ) + | Pmty_signature signature -> + let signatureDoc = Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.line; + printSignature signature cmtTbl; + ] + ); + Doc.line; + Doc.rbrace; + ] + ) in + Doc.concat [ + printAttributes modType.pmty_attributes cmtTbl; + signatureDoc + ] + | Pmty_functor _ -> + let (parameters, returnType) = ParsetreeViewer.functorType modType in + let parametersDoc = match parameters with + | [] -> Doc.nil + | [attrs, {Location.txt = "_"; loc}, Some modType] -> + let cmtLoc = + {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + in + let attrs = printAttributes attrs cmtTbl in + let doc = Doc.concat [ + attrs; + printModType modType cmtTbl + ] in + printComments doc cmtTbl cmtLoc + | params -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun (attrs, lbl, modType) -> + let cmtLoc = match modType with + | None -> lbl.Asttypes.loc + | Some modType -> + {lbl.Asttypes.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} + in + let attrs = printAttributes attrs cmtTbl in + let lblDoc = if lbl.Location.txt = "_" then Doc.nil + else + let doc = Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = Doc.concat [ + attrs; + lblDoc; + (match modType with + | None -> Doc.nil + | Some modType -> Doc.concat [ + if lbl.txt = "_" then Doc.nil else Doc.text ": "; + printModType modType cmtTbl; + ]); + ] in + printComments doc cmtTbl cmtLoc + ) params + ); + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + in + let returnDoc = + let doc = printModType returnType cmtTbl in + if Parens.modTypeFunctorReturn returnType then addParens doc else doc + in + Doc.group ( + Doc.concat [ + parametersDoc; + Doc.group ( + Doc.concat [ + Doc.text " =>"; + Doc.line; + returnDoc; + ] + ) + ] + ) + | Pmty_typeof modExpr -> Doc.concat [ + Doc.text "module type of "; + printModExpr modExpr cmtTbl + ] + | Pmty_extension extension -> printExtension ~atModuleLvl:false extension cmtTbl + | Pmty_alias longident -> Doc.concat [ + Doc.text "module "; + printLongidentLocation longident cmtTbl; + ] + | Pmty_with (modType, withConstraints) -> + let operand = + let doc = printModType modType cmtTbl in + if Parens.modTypeWithOperand modType then addParens doc else doc + in + Doc.group ( + Doc.concat [ + operand; + Doc.indent ( + Doc.concat [ + Doc.line; + printWithConstraints withConstraints cmtTbl; + ] + ) + ] + ) + in + let attrsAlreadyPrinted = match modType.pmty_desc with + | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true + | _ -> false + in + let doc =Doc.concat [ + if attrsAlreadyPrinted then Doc.nil else printAttributes modType.pmty_attributes cmtTbl; + modTypeDoc; + ] in + printComments doc cmtTbl modType.pmty_loc + +and printWithConstraints withConstraints cmtTbl = + let rows = List.mapi (fun i withConstraint -> + Doc.group ( + Doc.concat [ + if i == 0 then Doc.text "with " else Doc.text "and "; + printWithConstraint withConstraint cmtTbl; + ] + ) + ) withConstraints + in + Doc.join ~sep:Doc.line rows + +and printWithConstraint (withConstraint : Parsetree.with_constraint) cmtTbl = + match withConstraint with + (* with type X.t = ... *) + | Pwith_type (longident, typeDeclaration) -> + Doc.group (printTypeDeclaration + ~name:(printLidentPath longident cmtTbl) + ~equalSign:"=" + ~recFlag:Doc.nil + 0 + typeDeclaration + CommentTable.empty) + (* with module X.Y = Z *) + | Pwith_module ({txt = longident1}, {txt = longident2}) -> + Doc.concat [ + Doc.text "module "; + printLongident longident1; + Doc.text " ="; + Doc.indent ( + Doc.concat [ + Doc.line; + printLongident longident2; + ] + ) + ] + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_typesubst (longident, typeDeclaration) -> + Doc.group(printTypeDeclaration + ~name:(printLidentPath longident cmtTbl) + ~equalSign:":=" + ~recFlag:Doc.nil + 0 + typeDeclaration + CommentTable.empty) + | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> + Doc.concat [ + Doc.text "module "; + printLongident longident1; + Doc.text " :="; + Doc.indent ( + Doc.concat [ + Doc.line; + printLongident longident2; + ] + ) + ] + +and printSignature signature cmtTbl = + match signature with + | [] -> printCommentsInside cmtTbl Location.none + | signature -> + printList + ~getLoc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:printSignatureItem + cmtTbl + +and printSignatureItem (si : Parsetree.signature_item) cmtTbl = + match si.psig_desc with + | Parsetree.Psig_value valueDescription -> + printValueDescription valueDescription cmtTbl + | Psig_type (recFlag, typeDeclarations) -> + let recFlag = match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + printTypeDeclarations ~recFlag typeDeclarations cmtTbl + | Psig_typext typeExtension -> + printTypeExtension typeExtension cmtTbl + | Psig_exception extensionConstructor -> + printExceptionDef extensionConstructor cmtTbl + | Psig_module moduleDeclaration -> + printModuleDeclaration moduleDeclaration cmtTbl + | Psig_recmodule moduleDeclarations -> + printRecModuleDeclarations moduleDeclarations cmtTbl + | Psig_modtype modTypeDecl -> + printModuleTypeDeclaration modTypeDecl cmtTbl + | Psig_open openDescription -> + printOpenDescription openDescription cmtTbl + | Psig_include includeDescription -> + printIncludeDescription includeDescription cmtTbl + | Psig_attribute attr -> Doc.concat [ + Doc.text "@"; + printAttribute attr cmtTbl + ] + | Psig_extension (extension, attrs) -> Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl]; + ] + | Psig_class _ | Psig_class_type _ -> Doc.nil + +and printRecModuleDeclarations moduleDeclarations cmtTbl = + printListi + ~getLoc:(fun n -> n.Parsetree.pmd_loc) + ~nodes:moduleDeclarations + ~print:printRecModuleDeclaration + cmtTbl + +and printRecModuleDeclaration md cmtTbl i = + let body = match md.pmd_type.pmty_desc with + | Parsetree.Pmty_alias longident -> + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + | _ -> + let needsParens = match md.pmd_type.pmty_desc with + | Pmty_with _ -> true + | _ -> false + in + let modTypeDoc = + let doc = printModType md.pmd_type cmtTbl in + if needsParens then addParens doc else doc + in + Doc.concat [Doc.text ": "; modTypeDoc] + in + let prefix = if i < 1 then "module rec " else "and " in + Doc.concat [ + printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + Doc.text prefix; + printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; + body + ] + +and printModuleDeclaration (md: Parsetree.module_declaration) cmtTbl = + let body = match md.pmd_type.pmty_desc with + | Parsetree.Pmty_alias longident -> + Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] + | _ -> Doc.concat [Doc.text ": "; printModType md.pmd_type cmtTbl] + in + Doc.concat [ + printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; + Doc.text "module "; + printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; + body + ] + +and printOpenDescription (openDescription : Parsetree.open_description) cmtTbl = + Doc.concat [ + printAttributes openDescription.popen_attributes cmtTbl; + Doc.text "open"; + (match openDescription.popen_override with + | Asttypes.Fresh -> Doc.space + | Asttypes.Override -> Doc.text "! "); + printLongidentLocation openDescription.popen_lid cmtTbl + ] + +and printIncludeDescription (includeDescription: Parsetree.include_description) cmtTbl = + Doc.concat [ + printAttributes includeDescription.pincl_attributes cmtTbl; + Doc.text "include "; + printModType includeDescription.pincl_mod cmtTbl; + ] + +and printIncludeDeclaration (includeDeclaration : Parsetree.include_declaration) cmtTbl = + Doc.concat [ + printAttributes includeDeclaration.pincl_attributes cmtTbl; + Doc.text "include "; + let includeDoc = + printModExpr includeDeclaration.pincl_mod cmtTbl + in + if Parens.includeModExpr includeDeclaration.pincl_mod then + addParens includeDoc + else includeDoc; + ] + +and printValueBindings ~recFlag (vbs: Parsetree.value_binding list) cmtTbl = + printListi + ~getLoc:(fun vb -> vb.Parsetree.pvb_loc) + ~nodes:vbs + ~print:(printValueBinding ~recFlag) + cmtTbl + +and printValueDescription valueDescription cmtTbl = + let isExternal = + match valueDescription.pval_prim with | [] -> false | _ -> true + in + let attrs = + printAttributes + ~loc:valueDescription.pval_name.loc + valueDescription.pval_attributes + cmtTbl + in + let header = + if isExternal then "external " else "let " in + Doc.group ( + Doc.concat [ + attrs; + Doc.text header; + printComments + (printIdentLike valueDescription.pval_name.txt) + cmtTbl + valueDescription.pval_name.loc; + Doc.text ": "; + printTypExpr valueDescription.pval_type cmtTbl; + if isExternal then + Doc.group ( + Doc.concat [ + Doc.text " ="; + Doc.indent( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.line ( + List.map(fun s -> Doc.concat [ + Doc.text "\""; + Doc.text s; + Doc.text "\""; + ]) + valueDescription.pval_prim + ); + ] + ) + ] + ) + else Doc.nil + ] + ) + +and printTypeDeclarations ~recFlag typeDeclarations cmtTbl = + printListi + ~getLoc:(fun n -> n.Parsetree.ptype_loc) + ~nodes:typeDeclarations + ~print:(printTypeDeclaration2 ~recFlag) + cmtTbl + +(* + * type_declaration = { + * ptype_name: string loc; + * ptype_params: (core_type * variance) list; + * (* ('a1,...'an) t; None represents _*) + * ptype_cstrs: (core_type * core_type * Location.t) list; + * (* ... constraint T1=T1' ... constraint Tn=Tn' *) + * ptype_kind: type_kind; + * ptype_private: private_flag; (* = private ... *) + * ptype_manifest: core_type option; (* = T *) + * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + * ptype_loc: Location.t; + * } + * + * + * type t (abstract, no manifest) + * type t = T0 (abstract, manifest=T0) + * type t = C of T | ... (variant, no manifest) + * type t = T0 = C of T | ... (variant, manifest=T0) + * type t = {l: T; ...} (record, no manifest) + * type t = T0 = {l : T; ...} (record, manifest=T0) + * type t = .. (open, no manifest) + * + * + * and type_kind = + * | Ptype_abstract + * | Ptype_variant of constructor_declaration list + * (* Invariant: non-empty list *) + * | Ptype_record of label_declaration list + * (* Invariant: non-empty list *) + * | Ptype_open + *) +and printTypeDeclaration ~name ~equalSign ~recFlag i (td: Parsetree.type_declaration) cmtTbl = + let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in + let prefix = if i > 0 then + Doc.text "and " + else + Doc.concat [Doc.text "type "; recFlag] + in + let typeName = name in + let typeParams = printTypeParams td.ptype_params cmtTbl in + let manifestAndKind = match td.ptype_kind with + | Ptype_abstract -> + begin match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> + Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printTypExpr typ cmtTbl; + ] + end + | Ptype_open -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] + | Ptype_record(lds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration lds cmtTbl; + ] + | Ptype_variant(cds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; + ] + in + let constraints = printTypeDefinitionConstraints td.ptype_cstrs in + Doc.group ( + Doc.concat [ + attrs; + prefix; + typeName; + typeParams; + manifestAndKind; + constraints; + ] + ) + +and printTypeDeclaration2 ~recFlag (td: Parsetree.type_declaration) cmtTbl i = + let name = + let doc = printIdentLike td.Parsetree.ptype_name.txt in + printComments doc cmtTbl td.ptype_name.loc + in + let equalSign = "=" in + let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in + let prefix = if i > 0 then + Doc.text "and " + else + Doc.concat [ + Doc.text "type "; + recFlag + ] + in + let typeName = name in + let typeParams = printTypeParams td.ptype_params cmtTbl in + let manifestAndKind = match td.ptype_kind with + | Ptype_abstract -> + begin match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> + Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printTypExpr typ cmtTbl; + ] + end + | Ptype_open -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + Doc.text ".."; + ] + | Ptype_record(lds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printPrivateFlag td.ptype_private; + printRecordDeclaration lds cmtTbl; + ] + | Ptype_variant(cds) -> + let manifest = match td.ptype_manifest with + | None -> Doc.nil + | Some(typ) -> Doc.concat [ + Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; + printTypExpr typ cmtTbl; + ] + in + Doc.concat [ + manifest; + Doc.concat [Doc.space; Doc.text equalSign]; + printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; + ] + in + let constraints = printTypeDefinitionConstraints td.ptype_cstrs in + Doc.group ( + Doc.concat [ + attrs; + prefix; + typeName; + typeParams; + manifestAndKind; + constraints; + ] + ) + +and printTypeDefinitionConstraints cstrs = + match cstrs with + | [] -> Doc.nil + | cstrs -> Doc.indent ( + Doc.group ( + Doc.concat [ + Doc.line; + Doc.group( + Doc.join ~sep:Doc.line ( + List.map printTypeDefinitionConstraint cstrs + ) + ) + ] + ) + ) + +and printTypeDefinitionConstraint ((typ1, typ2, _loc ): Parsetree.core_type * Parsetree.core_type * Location.t) = + Doc.concat [ + Doc.text "constraint "; + printTypExpr typ1 CommentTable.empty; + Doc.text " = "; + printTypExpr typ2 CommentTable.empty; + ] + +and printPrivateFlag (flag : Asttypes.private_flag) = match flag with + | Private -> Doc.text "private " + | Public -> Doc.nil + +and printTypeParams typeParams cmtTbl = + match typeParams with + | [] -> Doc.nil + | typeParams -> + Doc.group ( + Doc.concat [ + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun typeParam -> + let doc = printTypeParam typeParam cmtTbl in + printComments doc cmtTbl (fst typeParam).Parsetree.ptyp_loc + ) typeParams + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ] + ) + +and printTypeParam (param : (Parsetree.core_type * Asttypes.variance)) cmtTbl = + let (typ, variance) = param in + let printedVariance = match variance with + | Covariant -> Doc.text "+" + | Contravariant -> Doc.text "-" + | Invariant -> Doc.nil + in + Doc.concat [ + printedVariance; + printTypExpr typ cmtTbl + ] + +and printRecordDeclaration (lds: Parsetree.label_declaration list) cmtTbl = + let forceBreak = match (lds, List.rev lds) with + | (first::_, last::_) -> + first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun ld -> + let doc = printLabelDeclaration ld cmtTbl in + printComments doc cmtTbl ld.Parsetree.pld_loc + ) lds) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] + ) + +and printConstructorDeclarations + ~privateFlag (cds: Parsetree.constructor_declaration list) cmtTbl += + let forceBreak = match (cds, List.rev cds) with + | (first::_, last::_) -> + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + | _ -> false + in + let privateFlag = match privateFlag with + | Asttypes.Private -> Doc.concat [ + Doc.text "private"; + Doc.line; + ] + | Public -> Doc.nil + in + let rows = + printListi + ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) + ~nodes:cds + ~print:(fun cd cmtTbl i -> + let doc = printConstructorDeclaration2 i cd cmtTbl in + printComments doc cmtTbl cd.Parsetree.pcd_loc + ) + ~forceBreak + cmtTbl + in + Doc.breakableGroup ~forceBreak ( + Doc.indent ( + Doc.concat [ + Doc.line; + privateFlag; + rows; + ] + ) + ) + +and printConstructorDeclaration2 i (cd : Parsetree.constructor_declaration) cmtTbl = + let attrs = printAttributes cd.pcd_attributes cmtTbl in + let bar = if i > 0 || cd.pcd_attributes <> [] then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil + in + let constrName = + let doc = Doc.text cd.pcd_name.txt in + printComments doc cmtTbl cd.pcd_name.loc + in + let constrArgs = printConstructorArguments ~indent:true cd.pcd_args cmtTbl in + let gadt = match cd.pcd_res with + | None -> Doc.nil + | Some(typ) -> Doc.indent ( + Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + ) + in + Doc.concat [ + bar; + Doc.group ( + Doc.concat [ + attrs; (* TODO: fix parsing of attributes, so when can print them above the bar? *) + constrName; + constrArgs; + gadt; + ] + ) + ] + +and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) cmtTbl = + match cdArgs with + | Pcstr_tuple [] -> Doc.nil + | Pcstr_tuple types -> + let args = Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun typexpr -> + printTypExpr typexpr cmtTbl + ) types + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] in + Doc.group ( + if indent then Doc.indent args else args + ) + | Pcstr_record lds -> + let args = Doc.concat [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun ld -> + let doc = printLabelDeclaration ld cmtTbl in + printComments doc cmtTbl ld.Parsetree.pld_loc + ) lds) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + Doc.rparen; + ] in + if indent then Doc.indent args else args + +and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = + let attrs = printAttributes ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl in + let mutableFlag = match ld.pld_mutable with + | Mutable -> Doc.text "mutable " + | Immutable -> Doc.nil + in + let name = + let doc = printIdentLike ld.pld_name.txt in + printComments doc cmtTbl ld.pld_name.loc + in + Doc.group ( + Doc.concat [ + attrs; + mutableFlag; + name; + Doc.text ": "; + printTypExpr ld.pld_type cmtTbl; + ] + ) + +and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = + let renderedType = match typExpr.ptyp_desc with + | Ptyp_any -> Doc.text "_" + | Ptyp_var var -> Doc.concat [ + Doc.text "'"; + printIdentLike ~allowUident:true var; + ] + | Ptyp_extension(extension) -> + printExtension ~atModuleLvl:false extension cmtTbl + | Ptyp_alias(typ, alias) -> + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needsParens = match typ.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false + in + let doc = printTypExpr typ cmtTbl in + if needsParens then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else + doc + in + Doc.concat [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] + + (* object printings *) + | Ptyp_object (fields, openFlag) -> + printObject ~inline:false fields openFlag cmtTbl + | Ptyp_constr(longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) -> + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.concat([ + constrName; + Doc.lessThan; + printObject ~inline:true fields openFlag cmtTbl; + Doc.greaterThan; + ]) + + | Ptyp_constr(longidentLoc, [{ ptyp_desc = Parsetree.Ptyp_tuple tuple }]) -> + let constrName = printLidentPath longidentLoc cmtTbl in + Doc.group( + Doc.concat([ + constrName; + Doc.lessThan; + printTupleType ~inline:true tuple cmtTbl; + Doc.greaterThan; + ]) + ) + | Ptyp_constr(longidentLoc, constrArgs) -> + let constrName = printLidentPath longidentLoc cmtTbl in + begin match constrArgs with + | [] -> constrName + | _args -> Doc.group( + Doc.concat([ + constrName; + Doc.lessThan; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map + (fun typexpr -> printTypExpr typexpr cmtTbl) + constrArgs + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.greaterThan; + ]) + ) + end + | Ptyp_arrow _ -> + let (attrsBefore, args, returnType) = ParsetreeViewer.arrowType typExpr in + let returnTypeNeedsParens = match returnType.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let returnDoc = + let doc = printTypExpr returnType cmtTbl in + if returnTypeNeedsParens then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + let (isUncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute attrsBefore + in + begin match args with + | [] -> Doc.nil + | [([], Nolabel, n)] when not isUncurried -> + let hasAttrsBefore = not (attrs = []) in + let attrs = if hasAttrsBefore then printAttributes ~inline:true attrsBefore cmtTbl else Doc.nil + in + let typDoc = + let doc = printTypExpr n cmtTbl in + match n.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc + | _ -> doc + in + Doc.group ( + Doc.concat [ + Doc.group attrs; + Doc.group ( + if hasAttrsBefore then + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + typDoc; + Doc.text " => "; + returnDoc; + ] + ); + Doc.softLine; + Doc.rparen + ] + else + Doc.concat [ + typDoc; + Doc.text " => "; + returnDoc; + ] + ) + ] + ) + | args -> + let attrs = printAttributes ~inline:true attrs cmtTbl in + let renderedArgs = Doc.concat [ + attrs; + Doc.text "("; + Doc.indent ( + Doc.concat [ + Doc.softLine; + if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun tp -> + printTypeParameter tp cmtTbl + ) args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.text ")"; + ] in + Doc.group ( + Doc.concat [ + renderedArgs; + Doc.text " => "; + returnDoc; + ] + ) + end + | Ptyp_tuple types -> printTupleType ~inline:false types cmtTbl + | Ptyp_poly([], typ) -> + printTypExpr typ cmtTbl + | Ptyp_poly(stringLocs, typ) -> + Doc.concat [ + Doc.join ~sep:Doc.space (List.map (fun {Location.txt; loc} -> + let doc = Doc.concat [Doc.text "'"; Doc.text txt] in + printComments doc cmtTbl loc + ) stringLocs); + Doc.dot; + Doc.space; + printTypExpr typ cmtTbl + ] + | Ptyp_package packageType -> + printPackageType ~printModuleKeywordAndParens:true packageType cmtTbl + | Ptyp_class _ -> + Doc.text "classes are not supported in types" + | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> + let forceBreak = typExpr.ptyp_loc.Location.loc_start.pos_lnum < typExpr.ptyp_loc.loc_end.pos_lnum in + let printRowField = function + | Parsetree.Rtag ({txt}, attrs, true, []) -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt] + ] + ) + | Rtag ({txt}, attrs, truth, types) -> + let doType t = match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> printTypExpr t cmtTbl + | _ -> Doc.concat [ Doc.lparen; printTypExpr t cmtTbl; Doc.rparen ] + in + let printedTypes = List.map doType types in + let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes in + let cases = if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases in + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.concat [Doc.text "#"; printPolyVarIdent txt]; + cases + ] + ) + | Rinherit coreType -> + printTypExpr coreType cmtTbl + in + let docs = List.map printRowField rowFields in + let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in + let cases = + if docs = [] then cases + else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] + in + let openingSymbol = + if closedFlag = Open + then Doc.concat [Doc.greaterThan; Doc.line] + else if labelsOpt = None + then Doc.softLine + else Doc.concat [Doc.lessThan; Doc.line] in + let labels = match labelsOpt with + | None + | Some([]) -> + Doc.nil + | Some(labels) -> + Doc.concat ( + List.map (fun label -> + Doc.concat [Doc.line; Doc.text "#" ; printPolyVarIdent label] + ) labels + ) + in + let closingSymbol = match labelsOpt with + | None | Some [] -> Doc.nil + | _ -> Doc.text " >" + in + Doc.breakableGroup ~forceBreak ( + Doc.concat [ + Doc.lbracket; + Doc.indent ( + Doc.concat [ + openingSymbol; + cases; + closingSymbol; + labels; + ] + ); + Doc.softLine; + Doc.rbracket + ] + ) + in + let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with + | Ptyp_arrow _ (* es6 arrow types print their own attributes *) -> true + | _ -> false + in + let doc = begin match typExpr.ptyp_attributes with + | _::_ as attrs when not shouldPrintItsOwnAttributes -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + renderedType; + ] + ) + | _ -> renderedType + end + in + printComments doc cmtTbl typExpr.ptyp_loc + +and printObject ~inline fields openFlag cmtTbl = + let doc = match fields with + | [] -> Doc.concat [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace + ] + | fields -> + Doc.concat [ + Doc.lbrace; + (match openFlag with + | Asttypes.Closed -> Doc.nil + | Open -> + begin match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | (Oinherit _)::_ -> Doc.text ".. " + | _ -> Doc.dotdot + end + ); + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun field -> printObjectField field cmtTbl) fields + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ] + in + if inline then doc else Doc.group doc + +and printTupleType ~inline (types: Parsetree.core_type list) cmtTbl = + let tuple = Doc.concat([ + Doc.lparen; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun typexpr -> printTypExpr typexpr cmtTbl) types + ) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ]) + in + if inline == false then Doc.group(tuple) else tuple + +and printObjectField (field : Parsetree.object_field) cmtTbl = + match field with + | Otag (labelLoc, attrs, typ) -> + let lbl = + let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in + printComments doc cmtTbl labelLoc.loc + in + let doc = Doc.concat [ + printAttributes ~loc:labelLoc.loc attrs cmtTbl; + lbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] in + let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in + printComments doc cmtTbl cmtLoc + | Oinherit typexpr -> + Doc.concat [ + Doc.dotdotdot; + printTypExpr typexpr cmtTbl + ] + +(* es6 arrow type arg + * type t = (~foo: string, ~bar: float=?, unit) => unit + * i.e. ~foo: string, ~bar: float *) +and printTypeParameter (attrs, lbl, typ) cmtTbl = + let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in + let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = printAttributes attrs cmtTbl in + let label = match lbl with + | Asttypes.Nolabel -> Doc.nil + | Labelled lbl -> Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + ] + | Optional lbl -> Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + ] + in + let optionalIndicator = match lbl with + | Asttypes.Nolabel + | Labelled _ -> Doc.nil + | Optional _lbl -> Doc.text "=?" + in + let (loc, typ) = match typ.ptyp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs -> + ({loc with loc_end = typ.ptyp_loc.loc_end}, {typ with ptyp_attributes = attrs}) + | _ -> (typ.ptyp_loc, typ) + in + let doc = Doc.group ( + Doc.concat [ + uncurried; + attrs; + label; + printTypExpr typ cmtTbl; + optionalIndicator; + ] + ) in + printComments doc cmtTbl loc + +and printValueBinding ~recFlag vb cmtTbl i = + let attrs = printAttributes ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes cmtTbl in + let header = + if i == 0 then + Doc.concat [ + Doc.text "let "; + recFlag + ] else + Doc.text "and " + in + match vb with + | {pvb_pat = + {ppat_desc = Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp))}; + pvb_expr = + {pexp_desc = Pexp_newtype _} as expr + } -> + let (_attrs, parameters, returnExpr) = ParsetreeViewer.funExpr expr in + let abstractType = match parameters with + | [NewTypes {locs = vars}] -> + Doc.concat [ + Doc.text "type "; + Doc.join ~sep:Doc.space (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + begin match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> + Doc.group ( + Doc.concat [ + attrs; + header; + printPattern pattern cmtTbl; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + abstractType; + Doc.space; + printTypExpr typ cmtTbl; + Doc.text " ="; + Doc.concat [ + Doc.line; + printExpressionWithComments expr cmtTbl; + ] + ] + ) + ] + ) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) + Doc.group ( + Doc.concat [ + attrs; + header; + printPattern pattern cmtTbl; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + abstractType; + Doc.space; + printTypExpr patTyp cmtTbl; + Doc.text " ="; + Doc.concat [ + Doc.line; + printExpressionWithComments expr cmtTbl; + ] + ] + ) + ] + ) + end + | _ -> + let (optBraces, expr) = ParsetreeViewer.processBracesAttr vb.pvb_expr in + let printedExpr = + let doc = printExpressionWithComments vb.pvb_expr cmtTbl in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let patternDoc = printPattern vb.pvb_pat cmtTbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then + Doc.customLayout [ + Doc.group ( + Doc.concat [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.space; + printedExpr; + ] + ); + Doc.group ( + Doc.concat [ + attrs; + header; + patternDoc; + Doc.text " ="; + Doc.indent ( + Doc.concat [ + Doc.line; + printedExpr; + ] + ) + ] + ); + ] + else + let shouldIndent = + match optBraces with + | Some _ -> false + | _ -> + ParsetreeViewer.isBinaryExpression expr || + (match vb.pvb_expr with + | { + pexp_attributes = [({Location.txt="ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _) + } -> + ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes || + ParsetreeViewer.isArrayAccess e + ) + in + Doc.group ( + Doc.concat [ + attrs; + header; + patternDoc; + Doc.text " ="; + if shouldIndent then + Doc.indent ( + Doc.concat [ + Doc.line; + printedExpr; + ] + ) + else + Doc.concat [ + Doc.space; + printedExpr; + ] + ] + ) + +and printPackageType ~printModuleKeywordAndParens (packageType: Parsetree.package_type) cmtTbl = + let doc = match packageType with + | (longidentLoc, []) -> Doc.group( + Doc.concat [ + printLongidentLocation longidentLoc cmtTbl; + ] + ) + | (longidentLoc, packageConstraints) -> Doc.group( + Doc.concat [ + printLongidentLocation longidentLoc cmtTbl; + printPackageConstraints packageConstraints cmtTbl; + Doc.softLine; + ] + ) + in + if printModuleKeywordAndParens then + Doc.concat[ + Doc.text "module("; + doc; + Doc.rparen + ] + else + doc + +and printPackageConstraints packageConstraints cmtTbl = + Doc.concat [ + Doc.text " with"; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.join ~sep:Doc.line ( + List.mapi (fun i pc -> + let (longident, typexpr) = pc in + let cmtLoc = {longident.Asttypes.loc with + loc_end = typexpr.Parsetree.ptyp_loc.loc_end + } in + let doc = printPackageConstraint i cmtTbl pc in + printComments doc cmtTbl cmtLoc + ) packageConstraints + ) + ] + ) + ] + +and printPackageConstraint i cmtTbl (longidentLoc, typ) = + let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in + Doc.concat [ + prefix; + printLongidentLocation longidentLoc cmtTbl; + Doc.text " = "; + printTypExpr typ cmtTbl; + ] + +and printExtension ~atModuleLvl (stringLoc, payload) cmtTbl = + let txt = convertBsExtension stringLoc.Location.txt in + let extName = + let doc = Doc.concat [ + Doc.text "%"; + if atModuleLvl then Doc.text "%" else Doc.nil; + Doc.text txt + ] in + printComments doc cmtTbl stringLoc.Location.loc + in + Doc.group ( + Doc.concat [ + extName; + printPayload payload cmtTbl; + ] + ) + +and printPattern (p : Parsetree.pattern) cmtTbl = + let patternWithoutAttributes = match p.ppat_desc with + | Ppat_any -> Doc.text "_" + | Ppat_var var -> printIdentLike var.txt + | Ppat_constant c -> printConstant c + | Ppat_tuple patterns -> + Doc.group( + Doc.concat([ + Doc.lparen; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun pat -> + printPattern pat cmtTbl) patterns) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen + ]) + ) + | Ppat_array [] -> + Doc.concat [ + Doc.lbracket; + printCommentsInside cmtTbl p.ppat_loc; + Doc.rbracket; + ] + | Ppat_array patterns -> + Doc.group( + Doc.concat([ + Doc.text "["; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun pat -> + printPattern pat cmtTbl) patterns) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.text "]"; + ]) + ) + | Ppat_construct({txt = Longident.Lident "()"}, _) -> + Doc.concat [ + Doc.lparen; + printCommentsInside cmtTbl p.ppat_loc; + Doc.rparen; + ] + | Ppat_construct({txt = Longident.Lident "[]"}, _) -> + Doc.concat [ + Doc.text "list{"; + printCommentsInside cmtTbl p.ppat_loc; + Doc.rbrace; + ] + | Ppat_construct({txt = Longident.Lident "::"}, _) -> + let (patterns, tail) = ParsetreeViewer.collectPatternsFromListConstruct [] p in + let shouldHug = match (patterns, tail) with + | ([pat], + {ppat_desc = Ppat_construct({txt = Longident.Lident "[]"}, _)}) when ParsetreeViewer.isHuggablePattern pat -> true + | _ -> false + in + let children = Doc.concat([ + if shouldHug then Doc.nil else Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun pat -> + printPattern pat cmtTbl) patterns); + begin match tail.Parsetree.ppat_desc with + | Ppat_construct({txt = Longident.Lident "[]"}, _) -> Doc.nil + | _ -> + let doc = Doc.concat [Doc.text "..."; printPattern tail cmtTbl] in + let tail = printComments doc cmtTbl tail.ppat_loc in + Doc.concat([Doc.text ","; Doc.line; tail]) + end; + ]) in + Doc.group( + Doc.concat([ + Doc.text "list{"; + if shouldHug then children else Doc.concat [ + Doc.indent children; + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + ]; + Doc.rbrace; + ]) + ) + | Ppat_construct(constrName, constructorArgs) -> + let constrName = printLongidentLocation constrName cmtTbl in + let argsDoc = match constructorArgs with + | None -> Doc.nil + | Some({ppat_loc; ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.concat [ + Doc.lparen; + printCommentsInside cmtTbl ppat_loc; + Doc.rparen; + ] + | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) -> + Doc.concat [ + Doc.lparen; + Doc.softLine; + printCommentsInside cmtTbl loc; + Doc.rparen; + ] + (* Some((1, 2) *) + | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + printPattern arg cmtTbl; + Doc.rparen; + ] + | Some({ppat_desc = Ppat_tuple patterns}) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun pat -> printPattern pat cmtTbl) patterns + ); + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = printPattern arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + + ] + in + Doc.group(Doc.concat [constrName; argsDoc]) + | Ppat_variant (label, None) -> + Doc.concat [Doc.text "#"; printPolyVarIdent label] + | Ppat_variant (label, variantArgs) -> + let variantName = + Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let argsDoc = match variantArgs with + | None -> Doc.nil + | Some({ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.text "()" + | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) -> + Doc.concat [ + Doc.lparen; + Doc.softLine; + printCommentsInside cmtTbl loc; + Doc.rparen; + ] + (* Some((1, 2) *) + | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + printPattern arg cmtTbl; + Doc.rparen; + ] + | Some({ppat_desc = Ppat_tuple patterns}) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun pat -> printPattern pat cmtTbl) patterns + ); + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = printPattern arg cmtTbl in + let shouldHug = ParsetreeViewer.isHuggablePattern arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + + ] + in + Doc.group(Doc.concat [variantName; argsDoc]) + | Ppat_type ident -> + Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] + | Ppat_record(rows, openFlag) -> + Doc.group( + Doc.concat([ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun row -> printPatternRecordRow row cmtTbl) rows); + begin match openFlag with + | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] + | Closed -> Doc.nil + end; + ] + ); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rbrace; + ]) + ) + + | Ppat_exception p -> + let needsParens = match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern p cmtTbl in + if needsParens then + Doc.concat [Doc.text "("; p; Doc.text ")"] + else + p + in + Doc.group ( + Doc.concat [Doc.text "exception"; Doc.line; pat] + ) + | Ppat_or _ -> + (* Blue | Red | Green -> [Blue; Red; Green] *) + let orChain = ParsetreeViewer.collectOrPatternChain p in + let docs = List.mapi (fun i pat -> + let patternDoc = printPattern pat cmtTbl in + Doc.concat [ + if i == 0 then Doc.nil else Doc.concat [Doc.line; Doc.text "| "]; + match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> addParens patternDoc + | _ -> patternDoc + ] + ) orChain in + let isSpreadOverMultipleLines = match (orChain, List.rev orChain) with + | first::_, last::_ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) + | Ppat_extension ext -> + printExtension ~atModuleLvl:false ext cmtTbl + | Ppat_lazy p -> + let needsParens = match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = printPattern p cmtTbl in + if needsParens then + Doc.concat [Doc.text "("; p; Doc.text ")"] + else + p + in + Doc.concat [Doc.text "lazy "; pat] + | Ppat_alias (p, aliasLoc) -> + let needsParens = match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let renderedPattern = + let p = printPattern p cmtTbl in + if needsParens then + Doc.concat [Doc.text "("; p; Doc.text ")"] + else + p + in + Doc.concat([ + renderedPattern; + Doc.text " as "; + printStringLoc aliasLoc cmtTbl; + ]) + + (* Note: module(P : S) is represented as *) + (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) + | Ppat_constraint ({ppat_desc = Ppat_unpack stringLoc}, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> + Doc.concat [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.text ": "; + printComments + (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl + ptyp_loc; + Doc.rparen; + ] + | Ppat_constraint (pattern, typ) -> + Doc.concat [ + printPattern pattern cmtTbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + + (* Note: module(P : S) is represented as *) + (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) + | Ppat_unpack stringLoc -> + Doc.concat [ + Doc.text "module("; + printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; + Doc.rparen; + ] + | Ppat_interval (a, b) -> + Doc.concat [ + printConstant a; + Doc.text " .. "; + printConstant b; + ] + | Ppat_open _ -> Doc.nil + in + let doc = match p.ppat_attributes with + | [] -> patternWithoutAttributes + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + patternWithoutAttributes; + ] + ) + in + printComments doc cmtTbl p.ppat_loc + +and printPatternRecordRow row cmtTbl = + match row with + (* punned {x}*) + | ({Location.txt=Longident.Lident ident} as longident, + {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt -> + printLidentPath longident cmtTbl + | (longident, pattern) -> + let locForComments = { + longident.loc with + loc_end = pattern.Parsetree.ppat_loc.loc_end + } in + let rhsDoc = + let doc = printPattern pattern cmtTbl in + if Parens.patternRecordRowRhs pattern then + addParens doc + else + doc + in + let doc = Doc.group ( + Doc.concat([ + printLidentPath longident cmtTbl; + Doc.text ":"; + (if ParsetreeViewer.isHuggablePattern pattern then + Doc.concat [Doc.space; rhsDoc] + else + Doc.indent( + Doc.concat [ + Doc.line; + rhsDoc; + ] + ) + ); + ]) + ) in + printComments doc cmtTbl locForComments + +and printExpressionWithComments expr cmtTbl = + let doc = printExpression expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc + +and printIfChain pexp_attributes ifs elseExpr cmtTbl = + let ifDocs = Doc.join ~sep:Doc.space ( + List.mapi (fun i (ifExpr, thenExpr) -> + let ifTxt = if i > 0 then Doc.text "else if " else Doc.text "if " in + match ifExpr with + | ParsetreeViewer.If ifExpr -> + let condition = + if ParsetreeViewer.isBlockExpr ifExpr then + printExpressionBlock ~braces:true ifExpr cmtTbl + else + let doc = printExpressionWithComments ifExpr cmtTbl in + match Parens.expr ifExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc ifExpr braces + | Nothing -> Doc.ifBreaks (addParens doc) doc + in + Doc.concat [ + ifTxt; + Doc.group (condition); + Doc.space; + let thenExpr = match ParsetreeViewer.processBracesAttr thenExpr with + (* This case only happens when coming from Reason, we strip braces *) + | (Some _, expr) -> expr + | _ -> thenExpr + in + printExpressionBlock ~braces:true thenExpr cmtTbl; + ] + | IfLet (pattern, conditionExpr) -> + let conditionDoc = + let doc = printExpressionWithComments conditionExpr cmtTbl in + match Parens.expr conditionExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc conditionExpr braces + | Nothing -> doc + in + Doc.concat [ + ifTxt; + Doc.text "let "; + printPattern pattern cmtTbl; + Doc.text " = "; + conditionDoc; + Doc.space; + printExpressionBlock ~braces:true thenExpr cmtTbl; + ] + ) ifs + ) in + let elseDoc = match elseExpr with + | None -> Doc.nil + | Some expr -> Doc.concat [ + Doc.text " else "; + printExpressionBlock ~braces:true expr cmtTbl; + ] + in + let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in + Doc.concat [ + printAttributes attrs cmtTbl; + ifDocs; + elseDoc; + ] + +and printExpression (e : Parsetree.expression) cmtTbl = + let printedExpression = match e.pexp_desc with + | Parsetree.Pexp_constant c -> printConstant c + | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> + printJsxFragment e cmtTbl + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat [ + Doc.text "list{"; + printCommentsInside cmtTbl e.pexp_loc; + Doc.rbrace; + ] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let (expressions, spread) = ParsetreeViewer.collectListExpressions e in + let spreadDoc = match spread with + | Some(expr) -> Doc.concat [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + ] + | None -> Doc.nil + in + Doc.group( + Doc.concat([ + Doc.text "list{"; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + ) + expressions); + spreadDoc; + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + ) + | Pexp_construct (longidentLoc, args) -> + let constr = printLongidentLocation longidentLoc cmtTbl in + let args = match args with + | None -> Doc.nil + | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.text "()" + (* Some((1, 2)) *) + | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + (let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some({pexp_desc = Pexp_tuple args }) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map + (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = + let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + ] + in + Doc.group(Doc.concat [constr; args]) + | Pexp_ident path -> + printLidentPath path cmtTbl + | Pexp_tuple exprs -> + Doc.group( + Doc.concat([ + Doc.lparen; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + exprs) + ]) + ); + Doc.ifBreaks (Doc.text ",") Doc.nil; + Doc.softLine; + Doc.rparen; + ]) + ) + | Pexp_array [] -> + Doc.concat [ + Doc.lbracket; + printCommentsInside cmtTbl e.pexp_loc; + Doc.rbracket; + ] + | Pexp_array exprs -> + Doc.group( + Doc.concat([ + Doc.lbracket; + Doc.indent ( + Doc.concat([ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + ) exprs) + ]) + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbracket; + ]) + ) + | Pexp_variant (label, args) -> + let variantName = + Doc.concat [Doc.text "#"; printPolyVarIdent label] in + let args = match args with + | None -> Doc.nil + | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) -> + Doc.text "()" + (* #poly((1, 2) *) + | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) -> + Doc.concat [ + Doc.lparen; + (let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some({pexp_desc = Pexp_tuple args }) -> + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map + (fun expr -> + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc) + args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + | Some(arg) -> + let argDoc = + let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + let shouldHug = ParsetreeViewer.isHuggableExpression arg in + Doc.concat [ + Doc.lparen; + if shouldHug then argDoc + else Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + argDoc; + ] + ); + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + ] + in + Doc.group(Doc.concat [variantName; args]) + | Pexp_record (rows, spreadExpr) -> + let spread = match spreadExpr with + | None -> Doc.nil + | Some expr -> Doc.concat [ + Doc.dotdotdot; + (let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let forceBreak = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak ( + Doc.concat([ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + spread; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun row -> printRecordRow row cmtTbl) rows) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + ) + | Pexp_extension extension -> + begin match extension with + | ( + {txt = "bs.obj" | "obj"}, + PStr [{ + pstr_loc = loc; + pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, []) + }] + ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let forceBreak = + loc.loc_start.pos_lnum < loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak ( + Doc.concat([ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun row -> printBsObjectRow row cmtTbl) rows) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rbrace; + ]) + ) + | extension -> + printExtension ~atModuleLvl:false extension cmtTbl + end + | Pexp_apply _ -> + if ParsetreeViewer.isUnaryExpression e then + printUnaryExpression e cmtTbl + else if ParsetreeViewer.isTemplateLiteral e then + printTemplateLiteral e cmtTbl + else if ParsetreeViewer.isBinaryExpression e then + printBinaryExpression e cmtTbl + else + printPexpApply e cmtTbl + | Pexp_unreachable -> Doc.dot + | Pexp_field (expr, longidentLoc) -> + let lhs = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.fieldExpr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + lhs; + Doc.dot; + printLidentPath longidentLoc cmtTbl; + ] + | Pexp_setfield (expr1, longidentLoc, expr2) -> + printSetFieldExpr e.pexp_attributes expr1 longidentLoc expr2 e.pexp_loc cmtTbl + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e -> + let (parts, alternate) = ParsetreeViewer.collectTernaryParts e in + let ternaryDoc = match parts with + | (condition1, consequent1)::rest -> + Doc.group (Doc.concat [ + printTernaryOperand condition1 cmtTbl; + Doc.indent ( + Doc.concat [ + Doc.line; + Doc.indent ( + Doc.concat [ + Doc.text "? "; + printTernaryOperand consequent1 cmtTbl + ] + ); + Doc.concat ( + List.map (fun (condition, consequent) -> + Doc.concat [ + Doc.line; + Doc.text ": "; + printTernaryOperand condition cmtTbl; + Doc.line; + Doc.text "? "; + printTernaryOperand consequent cmtTbl; + ] + ) rest + ); + Doc.line; + Doc.text ": "; + Doc.indent (printTernaryOperand alternate cmtTbl); + ] + ) + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in + let needsParens = match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> false | _ -> true + in + Doc.concat [ + printAttributes attrs cmtTbl; + if needsParens then addParens ternaryDoc else ternaryDoc; + ] + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> + let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in + printIfChain e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_while (expr1, expr2) -> + let condition = + let doc = printExpressionWithComments expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "while "; + if ParsetreeViewer.isBlockExpr expr1 then + condition + else + Doc.group ( + Doc.ifBreaks (addParens condition) condition + ); + Doc.space; + printExpressionBlock ~braces:true expr2 cmtTbl; + ] + ) + | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.text "for "; + printPattern pattern cmtTbl; + Doc.text " in "; + (let doc = printExpressionWithComments fromExpr cmtTbl in + match Parens.expr fromExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc fromExpr braces + | Nothing -> doc); + printDirectionFlag directionFlag; + (let doc = printExpressionWithComments toExpr cmtTbl in + match Parens.expr toExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc toExpr braces + | Nothing -> doc); + Doc.space; + printExpressionBlock ~braces:true body cmtTbl; + ] + ) + | Pexp_constraint( + {pexp_desc = Pexp_pack modExpr}, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} + ) -> + Doc.group ( + Doc.concat [ + Doc.text "module("; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printModExpr modExpr cmtTbl; + Doc.text ": "; + printComments + (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl) + cmtTbl + ptyp_loc + ] + ); + Doc.softLine; + Doc.rparen; + ] + ) + + | Pexp_constraint (expr, typ) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + exprDoc; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_letexception (_extensionConstructor, _expr) -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_assert expr -> + let rhs = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.lazyOrAssertExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + Doc.text "assert "; + rhs; + ] + | Pexp_lazy expr -> + let rhs = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.lazyOrAssertExprRhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.group ( + Doc.concat [ + Doc.text "lazy "; + rhs; + ] + ) + | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_pack (modExpr) -> + Doc.group (Doc.concat [ + Doc.text "module("; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printModExpr modExpr cmtTbl; + ] + ); + Doc.softLine; + Doc.rparen; + ]) + | Pexp_sequence _ -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_let _ -> + printExpressionBlock ~braces:true e cmtTbl + | Pexp_fun (Nolabel, None, {ppat_desc = Ppat_var {txt="__x"}}, ({pexp_desc = Pexp_apply _})) -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + printExpressionWithComments (ParsetreeViewer.rewriteUnderscoreApply e) cmtTbl + | Pexp_fun _ | Pexp_newtype _ -> + let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in + let (uncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute attrsOnArrow + in + let (returnExpr, typConstraint) = match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> ( + {expr with pexp_attributes = List.concat [ + expr.pexp_attributes; + returnExpr.pexp_attributes; + ]}, + Some typ + ) + | _ -> (returnExpr, None) + in + let hasConstraint = match typConstraint with | Some _ -> true | None -> false in + let parametersDoc = printExprFunParameters + ~inCallback:NoCallback + ~uncurried + ~hasConstraint + parameters + cmtTbl + in + let returnExprDoc = + let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = match (returnExpr.pexp_desc, optBraces) with + | (_, Some _ ) -> true + | ((Pexp_array _ + | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _), _) -> true + | _ -> false + in + let shouldIndent = match returnExpr.pexp_desc with + | Pexp_sequence _ + | Pexp_let _ + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_open _ -> false + | _ -> true + in + let returnDoc = + let doc = printExpressionWithComments returnExpr cmtTbl in + match Parens.expr returnExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc returnExpr braces + | Nothing -> doc + in + if shouldInline then Doc.concat [ + Doc.space; + returnDoc; + ] else + Doc.group ( + if shouldIndent then + Doc.indent ( + Doc.concat [ + Doc.line; + returnDoc; + ] + ) + else + Doc.concat [ + Doc.space; + returnDoc + ] + ) + in + let typConstraintDoc = match typConstraint with + | Some(typ) -> + let typDoc = + let doc = printTypExpr typ cmtTbl in + if Parens.arrowReturnTypExpr typ then + addParens doc + else + doc + in + Doc.concat [Doc.text ": "; typDoc] + | _ -> Doc.nil + in + let attrs = printAttributes attrs cmtTbl in + Doc.group ( + Doc.concat [ + attrs; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ] + ) + | Pexp_try (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + Doc.text "try "; + exprDoc; + Doc.text " catch "; + printCases cases cmtTbl; + ] + | Pexp_match (_, [_;_]) when ParsetreeViewer.isIfLetExpr e -> + let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in + printIfChain e.pexp_attributes ifs elseExpr cmtTbl + | Pexp_match (expr, cases) -> + let exprDoc = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + Doc.concat [ + Doc.text "switch "; + exprDoc; + Doc.space; + printCases cases cmtTbl; + ] + | Pexp_function cases -> + Doc.concat [ + Doc.text "x => switch x "; + printCases cases cmtTbl; + ] + | Pexp_coerce (expr, typOpt, typ) -> + let docExpr = printExpressionWithComments expr cmtTbl in + let docTyp = printTypExpr typ cmtTbl in + let ofType = match typOpt with + | None -> Doc.nil + | Some(typ1) -> + Doc.concat [Doc.text ": "; printTypExpr typ1 cmtTbl] + in + Doc.concat [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] + | Pexp_send (parentExpr, label) -> + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group ( + Doc.concat [ + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ] + ) + | Pexp_new _ -> + Doc.text "Pexp_new not impemented in printer" + | Pexp_setinstvar _ -> + Doc.text "Pexp_setinstvar not impemented in printer" + | Pexp_override _ -> + Doc.text "Pexp_override not impemented in printer" + | Pexp_poly _ -> + Doc.text "Pexp_poly not impemented in printer" + | Pexp_object _ -> + Doc.text "Pexp_object not impemented in printer" + in + let shouldPrintItsOwnAttributes = match e.pexp_desc with + | Pexp_apply _ + | Pexp_fun _ + | Pexp_newtype _ + | Pexp_setfield _ + | Pexp_ifthenelse _ -> true + | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true + | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> true + | _ -> false + in + match e.pexp_attributes with + | [] -> printedExpression + | attrs when not shouldPrintItsOwnAttributes -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + printedExpression; + ] + ) + | _ -> printedExpression + +and printPexpFun ~inCallback e cmtTbl = + let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in + let (uncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute attrsOnArrow + in + let (returnExpr, typConstraint) = match returnExpr.pexp_desc with + | Pexp_constraint (expr, typ) -> ( + {expr with pexp_attributes = List.concat [ + expr.pexp_attributes; + returnExpr.pexp_attributes; + ]}, + Some typ + ) + | _ -> (returnExpr, None) + in + let parametersDoc = printExprFunParameters + ~inCallback + ~uncurried + ~hasConstraint:(match typConstraint with | Some _ -> true | None -> false) + parameters cmtTbl in + let returnShouldIndent = match returnExpr.pexp_desc with + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> false + | _ -> true + in + let returnExprDoc = + let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in + let shouldInline = match (returnExpr.pexp_desc, optBraces) with + | (_, Some _) -> true + | ((Pexp_array _ + | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _), _) -> true + | _ -> false + in + let returnDoc = + let doc = printExpressionWithComments returnExpr cmtTbl in + match Parens.expr returnExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc returnExpr braces + | Nothing -> doc + in + if shouldInline then Doc.concat [ + Doc.space; + returnDoc; + ] else + Doc.group ( + if returnShouldIndent then + Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.line; + returnDoc; + ] + ); + (match inCallback with + | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine + | _ -> Doc.nil); + ] + else + Doc.concat [ + Doc.space; + returnDoc; + ] + ) + in + let typConstraintDoc = match typConstraint with + | Some(typ) -> Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl + ] + | _ -> Doc.nil + in + Doc.concat [ + printAttributes attrs cmtTbl; + parametersDoc; + typConstraintDoc; + Doc.text " =>"; + returnExprDoc; + ] + +and printTernaryOperand expr cmtTbl = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.ternaryOperand expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + +and printSetFieldExpr attrs lhs longidentLoc rhs loc cmtTbl = + let rhsDoc = + let doc = printExpressionWithComments rhs cmtTbl in + match Parens.setFieldExprRhs rhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc rhs braces + | Nothing -> doc + in + let lhsDoc = + let doc = printExpressionWithComments lhs cmtTbl in + match Parens.fieldExpr lhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc lhs braces + | Nothing -> doc + in + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group (Doc.concat [ + lhsDoc; + Doc.dot; + printLidentPath longidentLoc cmtTbl; + Doc.text " ="; + if shouldIndent then Doc.group ( + Doc.indent ( + (Doc.concat [Doc.line; rhsDoc]) + ) + ) else + Doc.concat [Doc.space; rhsDoc] + ]) in + let doc = match attrs with + | [] -> doc + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + doc + ] + ) + in + printComments doc cmtTbl loc + +and printTemplateLiteral expr cmtTbl = + let tag = ref "js" in + let rec walkExpr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, + [Nolabel, arg1; Nolabel, arg2] + ) -> + let lhs = walkExpr arg1 in + let rhs = walkExpr arg2 in + Doc.concat [lhs; rhs] + | Pexp_constant (Pconst_string (txt, Some prefix)) -> + tag := prefix; + printStringContents txt + | _ -> + let doc = printExpressionWithComments expr cmtTbl in + Doc.group ( + Doc.concat [ + Doc.text "${"; + Doc.indent doc; + Doc.rbrace; + ] + ) + in + let content = walkExpr expr in + Doc.concat [ + if !tag = "js" then Doc.nil else Doc.text !tag; + Doc.text "`"; + content; + Doc.text "`" + ] + +and printUnaryExpression expr cmtTbl = + let printUnaryOperator op = Doc.text ( + match op with + | "~+" -> "+" + | "~+." -> "+." + | "~-" -> "-" + | "~-." -> "-." + | "not" -> "!" + | _ -> assert false + ) in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, operand] + ) -> + let printedOperand = + let doc = printExpressionWithComments operand cmtTbl in + match Parens.unaryExprOperand operand with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [ + printUnaryOperator operator; + printedOperand; + ] in + printComments doc cmtTbl expr.pexp_loc + | _ -> assert false + +and printBinaryExpression (expr : Parsetree.expression) cmtTbl = + let printBinaryOperator ~inlineRhs operator = + let operatorTxt = match operator with + | "|." -> "->" + | "^" -> "++" + | "=" -> "==" + | "==" -> "===" + | "<>" -> "!=" + | "!=" -> "!==" + | txt -> txt + in + let spacingBeforeOperator = + if operator = "|." then Doc.softLine + else if operator = "|>" then Doc.line + else Doc.space; + in + let spacingAfterOperator = + if operator = "|." then Doc.nil + else if operator = "|>" then Doc.space + else if inlineRhs then Doc.space else Doc.line + in + Doc.concat [ + spacingBeforeOperator; + Doc.text operatorTxt; + spacingAfterOperator; + ] + in + let printOperand ~isLhs expr parentOperator = + let rec flatten ~isLhs expr parentOperator = + if ParsetreeViewer.isBinaryExpression expr then + begin match expr with + | {pexp_desc = Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [_, left; _, right] + )} -> + if ParsetreeViewer.flattenableOperators parentOperator operator && + not (ParsetreeViewer.hasAttributes expr.pexp_attributes) + then + let leftPrinted = flatten ~isLhs:true left operator in + let rightPrinted = + let (_, rightAttrs) = + ParsetreeViewer.partitionPrinteableAttributes right.pexp_attributes + in + let doc = + printExpressionWithComments + {right with pexp_attributes = rightAttrs} + cmtTbl + in + let doc = if Parens.flattenOperandRhs parentOperator right then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else + doc + in + let printeableAttrs = + ParsetreeViewer.filterPrinteableAttributes right.pexp_attributes + in + Doc.concat [printAttributes printeableAttrs cmtTbl; doc] + in + let doc = Doc.concat [ + leftPrinted; + printBinaryOperator ~inlineRhs:false operator; + rightPrinted; + ] in + let doc = + if not isLhs && (Parens.rhsBinaryExprOperand operator expr) then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + printComments doc cmtTbl expr.pexp_loc + else ( + let doc = printExpressionWithComments {expr with pexp_attributes = []} cmtTbl in + let doc = if Parens.subBinaryExprOperand parentOperator operator || + (expr.pexp_attributes <> [] && + (ParsetreeViewer.isBinaryExpression expr || + ParsetreeViewer.isTernaryExpr expr)) + then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + doc + ] + ) + | _ -> assert false + end + else + begin match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, + [Nolabel, _; Nolabel, _] + ) when loc.loc_ghost -> + let doc = printTemplateLiteral expr cmtTbl in + printComments doc cmtTbl expr.Parsetree.pexp_loc + | Pexp_setfield (lhs, field, rhs) -> + let doc = printSetFieldExpr expr.pexp_attributes lhs field rhs expr.pexp_loc cmtTbl in + if isLhs then addParens doc else doc + | Pexp_apply( + {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [(Nolabel, lhs); (Nolabel, rhs)] + ) -> + let rhsDoc = printExpressionWithComments rhs cmtTbl in + let lhsDoc = printExpressionWithComments lhs cmtTbl in + (* TODO: unify indentation of "=" *) + let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group ( + Doc.concat [ + lhsDoc; + Doc.text " ="; + if shouldIndent then Doc.group ( + Doc.indent (Doc.concat [Doc.line; rhsDoc]) + ) else + Doc.concat [Doc.space; rhsDoc] + ] + ) in + let doc = match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + doc + ] + ) + in + if isLhs then addParens doc else doc + | _ -> + let doc = printExpressionWithComments expr cmtTbl in + begin match Parens.binaryExprOperand ~isLhs expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + end + end + in + flatten ~isLhs expr parentOperator + in + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, + [Nolabel, lhs; Nolabel, rhs] + ) when not ( + ParsetreeViewer.isBinaryExpression lhs || + ParsetreeViewer.isBinaryExpression rhs + ) -> + let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in + let lhsDoc = printOperand ~isLhs:true lhs op in + let rhsDoc = printOperand ~isLhs:false rhs op in + Doc.group ( + Doc.concat [ + lhsDoc; + (match lhsHasCommentBelow, op with + | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"] + | false, "|." -> Doc.text "->" + | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] + | false, "|>" -> Doc.text " |> " + | _ -> Doc.nil + ); + rhsDoc; + ] + ) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, + [Nolabel, lhs; Nolabel, rhs] + ) -> + let right = + let operatorWithRhs = + let rhsDoc = printOperand ~isLhs:false rhs operator in + Doc.concat [ + printBinaryOperator + ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) operator; + rhsDoc; + ] in + if ParsetreeViewer.shouldIndentBinaryExpr expr then + Doc.group (Doc.indent operatorWithRhs) + else operatorWithRhs + in + let doc = Doc.group ( + Doc.concat [ + printOperand ~isLhs:true lhs operator; + right + ] + ) in + Doc.group ( + Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + match Parens.binaryExpr {expr with + pexp_attributes = List.filter (fun attr -> + match attr with + | ({Location.txt = ("ns.braces")}, _) -> false + | _ -> true + ) expr.pexp_attributes + } with + | Braced(bracesLoc) -> printBraces doc expr bracesLoc + | Parenthesized -> addParens doc + | Nothing -> doc; + ] + ) + | _ -> Doc.nil + +(* callExpr(arg1, arg2) *) +and printPexpApply expr cmtTbl = + match expr.pexp_desc with + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, + [Nolabel, parentExpr; Nolabel, memberExpr] + ) -> + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + let member = + let memberDoc = match memberExpr.pexp_desc with + | Pexp_ident lident -> + printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc + | _ -> printExpressionWithComments memberExpr cmtTbl + in + Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] + in + Doc.group (Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, + [Nolabel, lhs; Nolabel, rhs] + ) -> + let rhsDoc = + let doc = printExpressionWithComments rhs cmtTbl in + match Parens.expr rhs with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc rhs braces + | Nothing -> doc + in + (* TODO: unify indentation of "=" *) + let shouldIndent = not (ParsetreeViewer.isBracedExpr rhs) && ParsetreeViewer.isBinaryExpression rhs in + let doc = Doc.group( + Doc.concat [ + printExpressionWithComments lhs cmtTbl; + Doc.text " ="; + if shouldIndent then Doc.group ( + Doc.indent ( + (Doc.concat [Doc.line; rhsDoc]) + ) + ) else + Doc.concat [Doc.space; rhsDoc] + ] + ) in + begin match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + doc + ] + ) + end + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, + [Nolabel, parentExpr; Nolabel, memberExpr] + ) when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let memberDoc = + let doc = printExpressionWithComments memberExpr cmtTbl in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc else ( + Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + memberDoc; + ] + ); + Doc.softLine + ] + ) + in + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group (Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply ( + {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, + [Nolabel, parentExpr; Nolabel, memberExpr; Nolabel, targetExpr] + ) -> + let member = + let memberDoc = + let doc = printExpressionWithComments memberExpr cmtTbl in + match Parens.expr memberExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc memberExpr braces + | Nothing -> doc + in + let shouldInline = match memberExpr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if shouldInline then memberDoc else ( + Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + memberDoc; + ] + ); + Doc.softLine + ] + ) + in + let shouldIndentTargetExpr = + if ParsetreeViewer.isBracedExpr targetExpr then + false + else + ParsetreeViewer.isBinaryExpression targetExpr || + (match targetExpr with + | { + pexp_attributes = [({Location.txt="ns.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (ifExpr, _, _) + } -> + ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes + | { pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.hasAttributes e.pexp_attributes || + ParsetreeViewer.isArrayAccess e + ) + in + let targetExpr = + let doc = printExpressionWithComments targetExpr cmtTbl in + match Parens.expr targetExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc targetExpr braces + | Nothing -> doc + in + let parentDoc = + let doc = printExpressionWithComments parentExpr cmtTbl in + match Parens.unaryExprOperand parentExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc parentExpr braces + | Nothing -> doc + in + Doc.group ( + Doc.concat [ + printAttributes expr.pexp_attributes cmtTbl; + parentDoc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + if shouldIndentTargetExpr then + Doc.indent ( + Doc.concat [ + Doc.line; + targetExpr; + ] + ) + else + Doc.concat [ + Doc.space; + targetExpr; + ] + ] + ) + (* TODO: cleanup, are those branches even remotely performant? *) + | Pexp_apply ( + {pexp_desc = Pexp_ident lident}, + args + ) when ParsetreeViewer.isJsxExpression expr -> + printJsxExpression lident args cmtTbl + | Pexp_apply (callExpr, args) -> + let args = List.map (fun (lbl, arg) -> + (lbl, ParsetreeViewer.rewriteUnderscoreApply arg) + ) args + in + let (uncurried, attrs) = + ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes + in + let callExprDoc = + let doc = printExpressionWithComments callExpr cmtTbl in + match Parens.callExpr callExpr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc callExpr braces + | Nothing -> doc + in + if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then + let argsDoc = + printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl + in + Doc.concat [ + printAttributes attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then + let argsDoc = + printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl + in + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybeBreakParent = + if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil + in + Doc.concat [ + maybeBreakParent; + printAttributes attrs cmtTbl; + callExprDoc; + argsDoc; + ] + else + let argsDoc = printArguments ~uncurried args cmtTbl in + Doc.concat [ + printAttributes attrs cmtTbl; + callExprDoc; + argsDoc; + ] + | _ -> assert false + +and printJsxExpression lident args cmtTbl = + let name = printJsxName lident in + let (formattedProps, children) = printJsxProps args cmtTbl in + (*
*) + let isSelfClosing = + match children with + | Some ({Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)}) -> true + | _ -> false + in + Doc.group ( + Doc.concat [ + Doc.group ( + Doc.concat [ + printComments (Doc.concat [Doc.lessThan; name]) cmtTbl lident.Asttypes.loc; + formattedProps; + if isSelfClosing then Doc.concat [Doc.line; Doc.text "/>"] else Doc.nil + ] + ); + if isSelfClosing then Doc.nil + else + Doc.concat [ + Doc.greaterThan; + Doc.indent ( + Doc.concat [ + Doc.line; + (match children with + | Some childrenExpression -> printJsxChildren childrenExpression cmtTbl + | None -> Doc.nil + ); + ] + ); + Doc.line; + Doc.text "" in + let closing = Doc.text "" in + (* let (children, _) = ParsetreeViewer.collectListExpressions expr in *) + Doc.group ( + Doc.concat [ + opening; + begin match expr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil + | _ -> + Doc.indent ( + Doc.concat [ + Doc.line; + printJsxChildren expr cmtTbl; + ] + ) + end; + Doc.line; + closing; + ] + ) + +and printJsxChildren (childrenExpr : Parsetree.expression) cmtTbl = + match childrenExpr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let (children, _) = ParsetreeViewer.collectListExpressions childrenExpr in + Doc.group ( + Doc.join ~sep:Doc.line ( + List.map (fun (expr : Parsetree.expression) -> + let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in + let exprDoc = printExpressionWithComments expr cmtTbl in + match Parens.jsxChildExpr expr with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = if Parens.bracedExpr expr then addParens exprDoc else exprDoc in + if leadingLineCommentPresent then + addBraces innerDoc + else + Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | Nothing -> exprDoc + ) children + ) + ) + | _ -> + let leadingLineCommentPresent = hasLeadingLineComment cmtTbl childrenExpr.pexp_loc in + let exprDoc = printExpressionWithComments childrenExpr cmtTbl in + Doc.concat [ + Doc.dotdotdot; + match Parens.jsxChildExpr childrenExpr with + | Parenthesized | Braced _ -> + let innerDoc = if Parens.bracedExpr childrenExpr then addParens exprDoc else exprDoc in + if leadingLineCommentPresent then + addBraces innerDoc + else + Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | Nothing -> exprDoc + ] + +and printJsxProps args cmtTbl :(Doc.t * Parsetree.expression option) = + let rec loop props args = + match args with + | [] -> (Doc.nil, None) + | [ + (Asttypes.Labelled "children", children); + ( + Asttypes.Nolabel, + {Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} + ) + ] -> + let formattedProps = Doc.indent ( + match props with + | [] -> Doc.nil + | props -> + Doc.concat [ + Doc.line; + Doc.group ( + Doc.join ~sep:Doc.line (props |> List.rev) + ) + ] + ) in + (formattedProps, Some children) + | arg::args -> + let propDoc = printJsxProp arg cmtTbl in + loop (propDoc::props) args + in + loop [] args + +and printJsxProp arg cmtTbl = + match arg with + | ( + (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl, + { + Parsetree.pexp_attributes = [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)]; + pexp_desc = Pexp_ident {txt = Longident.Lident ident} + } + ) when lblTxt = ident (* jsx punning *) -> + begin match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> + printComments (printIdentLike ident) cmtTbl argLoc + | Optional _lbl -> + let doc = Doc.concat [ + Doc.question; + printIdentLike ident; + ] in + printComments doc cmtTbl argLoc + end + | ( + (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl, + { + Parsetree.pexp_attributes = []; + pexp_desc = Pexp_ident {txt = Longident.Lident ident} + } + ) when lblTxt = ident (* jsx punning when printing from Reason *) -> + begin match lbl with + | Nolabel -> Doc.nil + | Labelled _lbl -> printIdentLike ident + | Optional _lbl -> Doc.concat [ + Doc.question; + printIdentLike ident; + ] + end + | (lbl, expr) -> + let (argLoc, expr) = match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> + Location.none, expr + in + let lblDoc = match lbl with + | Asttypes.Labelled lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal] + | Asttypes.Optional lbl -> + let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in + Doc.concat [lbl; Doc.equal; Doc.question] + | Nolabel -> Doc.nil + in + let exprDoc = + let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in + let doc = printExpressionWithComments expr cmtTbl in + match Parens.jsxPropExpr expr with + | Parenthesized | Braced(_) -> + (* {(20: int)} make sure that we also protect the expression inside *) + let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in + if leadingLineCommentPresent then + addBraces innerDoc + else + Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] + | _ -> doc + in + let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + printComments + (Doc.concat [ + lblDoc; + exprDoc; + ]) + cmtTbl + fullLoc + +(* div -> div. + * Navabar.createElement -> Navbar + * Staff.Users.createElement -> Staff.Users *) +and printJsxName {txt = lident} = + let rec flatten acc lident = match lident with + | Longident.Lident txt -> txt::acc + | Ldot (lident, txt) -> + let acc = if txt = "createElement" then acc else txt::acc in + flatten acc lident + | _ -> acc + in + match lident with + | Longident.Lident txt -> Doc.text txt + | _ as lident -> + let segments = flatten [] lident in + Doc.join ~sep:Doc.dot (List.map Doc.text segments) + +and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = + (* Because the same subtree gets printed twice, we need to copy the cmtTbl. + * consumed comments need to be marked not-consumed and reprinted… + * Cheng's different comment algorithm will solve this. *) + let cmtTblCopy = CommentTable.copy cmtTbl in + let (callback, printedArgs) = match args with + | (lbl, expr)::args -> + let lblDoc = match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; + ] + | Asttypes.Optional txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; Doc.question; + ] + in + let callback = Doc.concat [ + lblDoc; + printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl + ] in + let callback = printComments callback cmtTbl expr.pexp_loc in + let printedArgs = + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun arg -> printArgument arg cmtTbl) args + ) + in + (callback, printedArgs) + | _ -> assert false + in + + (* Thing.map((arg1, arg2) => MyModuleBlah.toList(argument), foo) *) + (* Thing.map((arg1, arg2) => { + * MyModuleBlah.toList(argument) + * }, longArgumet, veryLooooongArgument) + *) + let fitsOnOneLine = Doc.concat [ + if uncurried then Doc.text "(. " else Doc.lparen; + callback; + Doc.comma; + Doc.line; + printedArgs; + Doc.rparen; + ] in + + (* Thing.map( + * (param1, parm2) => doStuff(param1, parm2), + * arg1, + * arg2, + * arg3, + * ) + *) + let breakAllArgs = printArguments ~uncurried args cmtTblCopy in + + (* Sometimes one of the non-callback arguments will break. + * There might be a single line comment in there, or a multiline string etc. + * showDialog( + * ~onConfirm={() => ()}, + * ` + * Do you really want to leave this workspace? + * Some more text with detailed explanations... + * `, + * ~danger=true, + * // comment --> here a single line comment + * ~confirmText="Yes, I am sure!", + * ) + * In this case, we always want the arguments broken over multiple lines, + * like a normal function call. + *) + if Doc.willBreak printedArgs then + breakAllArgs + else + Doc.customLayout [ + fitsOnOneLine; + breakAllArgs; + ] + +and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = + (* Because the same subtree gets printed twice, we need to copy the cmtTbl. + * consumed comments need to be marked not-consumed and reprinted… + * Cheng's different comment algorithm will solve this. *) + let cmtTblCopy = CommentTable.copy cmtTbl in + let cmtTblCopy2 = CommentTable.copy cmtTbl in + let rec loop acc args = match args with + | [] -> (Doc.nil, Doc.nil, Doc.nil) + | [lbl, expr] -> + let lblDoc = match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; + ] + | Asttypes.Optional txt -> + Doc.concat [ + Doc.tilde; printIdentLike txt; Doc.equal; Doc.question; + ] + in + let callbackFitsOnOneLine = + let pexpFunDoc = printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTbl expr.pexp_loc + in + let callbackArgumentsFitsOnOneLine = + let pexpFunDoc = printPexpFun ~inCallback:ArgumentsFitOnOneLine expr cmtTblCopy in + let doc = Doc.concat [lblDoc; pexpFunDoc] in + printComments doc cmtTblCopy expr.pexp_loc + in + ( + Doc.concat (List.rev acc), + callbackFitsOnOneLine, + callbackArgumentsFitsOnOneLine + ) + | arg::args -> + let argDoc = printArgument arg cmtTbl in + loop (Doc.line::Doc.comma::argDoc::acc) args + in + let (printedArgs, callback, callback2) = loop [] args in + + (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *) + let fitsOnOneLine = Doc.concat [ + if uncurried then Doc.text "(." else Doc.lparen; + printedArgs; + callback; + Doc.rparen; + ] in + + (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => + * MyModuleBlah.toList(argument) + * ) + *) + let arugmentsFitOnOneLine = + Doc.concat [ + if uncurried then Doc.text "(." else Doc.lparen; + printedArgs; + Doc.breakableGroup ~forceBreak:true callback2; + Doc.rparen; + ] + in + + (* Thing.map( + * arg1, + * arg2, + * arg3, + * (param1, parm2) => doStuff(param1, parm2) + * ) + *) + let breakAllArgs = printArguments ~uncurried args cmtTblCopy2 in + + (* Sometimes one of the non-callback arguments will break. + * There might be a single line comment in there, or a multiline string etc. + * showDialog( + * ` + * Do you really want to leave this workspace? + * Some more text with detailed explanations... + * `, + * ~danger=true, + * // comment --> here a single line comment + * ~confirmText="Yes, I am sure!", + * ~onConfirm={() => ()}, + * ) + * In this case, we always want the arguments broken over multiple lines, + * like a normal function call. + *) + if Doc.willBreak printedArgs then + breakAllArgs + else + Doc.customLayout [ + fitsOnOneLine; + arugmentsFitOnOneLine; + breakAllArgs; + ] + +and printArguments ~uncurried (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl = + match args with + | [Nolabel, {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); pexp_loc = loc}] -> + (* See "parseCallExpr", ghost unit expression is used the implement + * arity zero vs arity one syntax. + * Related: https://github.com/rescript-lang/syntax/issues/138 *) + begin match uncurried, loc.loc_ghost with + | true, true -> Doc.text "(.)" (* arity zero *) + | true, false -> Doc.text "(. ())" (* arity one *) + | _ -> Doc.text "()" + end + | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> + let argDoc = + let doc = printExpressionWithComments arg cmtTbl in + match Parens.expr arg with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc arg braces + | Nothing -> doc + in + Doc.concat [ + if uncurried then Doc.text "(. " else Doc.lparen; + argDoc; + Doc.rparen; + ] + | args -> Doc.group ( + Doc.concat [ + if uncurried then Doc.text "(." else Doc.lparen; + Doc.indent ( + Doc.concat [ + if uncurried then Doc.line else Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun arg -> printArgument arg cmtTbl) args + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + +(* + * argument ::= + * | _ (* syntax sugar *) + * | expr + * | expr : type + * | ~ label-name + * | ~ label-name + * | ~ label-name ? + * | ~ label-name = expr + * | ~ label-name = _ (* syntax sugar *) + * | ~ label-name = expr : type + * | ~ label-name = ? expr + * | ~ label-name = ? _ (* syntax sugar *) + * | ~ label-name = ? expr : type *) +and printArgument (argLbl, arg) cmtTbl = + match (argLbl, arg) with + (* ~a (punned)*) + | ( + (Asttypes.Labelled lbl), + ({pexp_desc=Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + } as argExpr) + ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> + let loc = match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ + Doc.tilde; + printIdentLike lbl + ] in + printComments doc cmtTbl loc + + (* ~a: int (punned)*) + | ( + (Asttypes.Labelled lbl), + {pexp_desc = Pexp_constraint ( + {pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr, + typ + ); + pexp_loc; + pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) as attrs + } + ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> + let loc = match attrs with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> + {loc with loc_end = pexp_loc.loc_end} + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ + Doc.tilde; + printIdentLike lbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] in + printComments doc cmtTbl loc + (* ~a? (optional lbl punned)*) + | ( + (Asttypes.Optional lbl), + {pexp_desc=Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + } + ) when lbl = name -> + let loc = match arg.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> loc + | _ -> arg.pexp_loc + in + let doc = Doc.concat [ + Doc.tilde; + printIdentLike lbl; + Doc.question; + ] in + printComments doc cmtTbl loc + | (_lbl, expr) -> + let (argLoc, expr) = match expr.pexp_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs -> + (loc, {expr with pexp_attributes = attrs}) + | _ -> + expr.pexp_loc, expr + in + let printedLbl = match argLbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled lbl -> + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in + printComments doc cmtTbl argLoc + | Asttypes.Optional lbl -> + let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] in + printComments doc cmtTbl argLoc + in + let printedExpr = + let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in + let doc = Doc.concat [ + printedLbl; + printedExpr; + ] in + printComments doc cmtTbl loc + +and printCases (cases: Parsetree.case list) cmtTbl = + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.lbrace; + Doc.concat [ + Doc.line; + printList + ~getLoc:(fun n -> {n.Parsetree.pc_lhs.ppat_loc with + loc_end = + match ParsetreeViewer.processBracesAttr n.Parsetree.pc_rhs with + | (None, _) -> n.pc_rhs.pexp_loc.loc_end + | (Some ({loc}, _), _) -> loc.Location.loc_end + }) + ~print:printCase + ~nodes:cases + cmtTbl + ]; + Doc.line; + Doc.rbrace; + ] + ) + +and printCase (case: Parsetree.case) cmtTbl = + let rhs = match case.pc_rhs.pexp_desc with + | Pexp_let _ + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_open _ + | Pexp_sequence _ -> + printExpressionBlock ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) case.pc_rhs cmtTbl + | _ -> + let doc = printExpressionWithComments case.pc_rhs cmtTbl in + begin match Parens.expr case.pc_rhs with + | Parenthesized -> addParens doc + | _ -> doc + end + + in + let guard = match case.pc_guard with + | None -> Doc.nil + | Some expr -> Doc.group ( + Doc.concat [ + Doc.line; + Doc.text "if "; + printExpressionWithComments expr cmtTbl; + ] + ) + in + let shouldInlineRhs = match case.pc_rhs.pexp_desc with + | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) + | Pexp_constant _ + | Pexp_ident _ -> true + | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true + | _ -> false + in + let shouldIndentPattern = match case.pc_lhs.ppat_desc with + | Ppat_or _ -> false + | _ -> true + in + let patternDoc = + let doc = printPattern case.pc_lhs cmtTbl in + match case.pc_lhs.ppat_desc with + | Ppat_constraint _ -> addParens doc + | _ -> doc + in + let content = Doc.concat [ + if shouldIndentPattern then Doc.indent patternDoc else patternDoc; + Doc.indent guard; + Doc.text " =>"; + Doc.indent ( + Doc.concat [ + if shouldInlineRhs then Doc.space else Doc.line; + rhs; + ] + ) + ] in + Doc.group ( + Doc.concat [ + Doc.text "| "; + content; + ] + ) + +and printExprFunParameters ~inCallback ~uncurried ~hasConstraint parameters cmtTbl = + match parameters with + (* let f = _ => () *) + | [ParsetreeViewer.Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = {Parsetree.ppat_desc = Ppat_any} + }] when not uncurried -> + if hasConstraint then Doc.text "(_)" else Doc.text "_" + (* let f = a => () *) + | [ParsetreeViewer.Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = {Parsetree.ppat_desc = Ppat_var stringLoc} + }] when not uncurried -> + let txtDoc = + let var = printIdentLike stringLoc.txt in + if hasConstraint then addParens var else var + in + printComments txtDoc cmtTbl stringLoc.loc + (* let f = () => () *) + | [ParsetreeViewer.Parameter { + attrs = []; + lbl = Asttypes.Nolabel; + defaultExpr = None; + pat = {ppat_desc = Ppat_construct({txt = Longident.Lident "()"}, None)} + }] when not uncurried -> + Doc.text "()" + (* let f = (~greeting, ~from as hometown, ~x=?) => () *) + | parameters -> + let inCallback = match inCallback with + | FitsOnOneLine -> true + | _ -> false + in + let lparen = if uncurried then Doc.text "(. " else Doc.lparen in + let shouldHug = ParsetreeViewer.parametersShouldHug parameters in + let printedParamaters = Doc.concat [ + if shouldHug || inCallback then Doc.nil else Doc.softLine; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun p -> printExpFunParameter p cmtTbl) parameters) + ] in + Doc.group ( + Doc.concat [ + lparen; + if shouldHug || inCallback then + printedParamaters + else + Doc.concat [ + Doc.indent printedParamaters; + Doc.trailingComma; + Doc.softLine; + ]; + Doc.rparen; + ] + ) + +and printExpFunParameter parameter cmtTbl = + match parameter with + | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.text "type "; + Doc.join ~sep:Doc.space (List.map (fun lbl -> + printComments (printIdentLike lbl.Asttypes.txt) cmtTbl lbl.Asttypes.loc + ) lbls) + ] + ) + | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> + let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in + let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in + let attrs = printAttributes attrs cmtTbl in + (* =defaultValue *) + let defaultExprDoc = match defaultExpr with + | Some expr -> Doc.concat [ + Doc.text "="; + printExpressionWithComments expr cmtTbl + ] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let labelWithPattern = match (lbl, pattern) with + | (Asttypes.Nolabel, pattern) -> printPattern pattern cmtTbl + | ( + (Asttypes.Labelled lbl | Optional lbl), + {ppat_desc = Ppat_var stringLoc; + ppat_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + } + ) when lbl = stringLoc.txt -> + (* ~d *) + Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + ] + | ( + (Asttypes.Labelled lbl | Optional lbl), + ({ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); + ppat_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) + }) + ) when lbl = txt -> + (* ~d: e *) + Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + | ((Asttypes.Labelled lbl | Optional lbl), pattern) -> + (* ~b as c *) + Doc.concat [ + Doc.text "~"; + printIdentLike lbl; + Doc.text " as "; + printPattern pattern cmtTbl + ] + in + let optionalLabelSuffix = match (lbl, defaultExpr) with + | (Asttypes.Optional _, None) -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = Doc.group ( + Doc.concat [ + uncurried; + attrs; + labelWithPattern; + defaultExprDoc; + optionalLabelSuffix; + ] + ) in + let cmtLoc = match defaultExpr with + | None -> + begin match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> + {loc with loc_end = pattern.ppat_loc.loc_end} + | _ -> pattern.ppat_loc + end + | Some expr -> + let startPos = match pattern.ppat_attributes with + | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> + loc.loc_start + | _ -> pattern.ppat_loc.loc_start + in { + pattern.ppat_loc with + loc_start = startPos; + loc_end = expr.pexp_loc.loc_end + } + in + printComments doc cmtTbl cmtLoc + +and printExpressionBlock ~braces expr cmtTbl = + let rec collectRows acc expr = match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> + let name = + let doc = Doc.text modName.txt in + printComments doc cmtTbl modName.loc + in + let letModuleDoc = Doc.concat [ + Doc.text "module "; + name; + Doc.text " = "; + printModExpr modExpr cmtTbl; + ] in + let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in + collectRows ((loc, letModuleDoc)::acc) expr2 + | Pexp_letexception (extensionConstructor, expr2) -> + let loc = + let loc = {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let letExceptionDoc = printExceptionDef extensionConstructor cmtTbl in + collectRows ((loc, letExceptionDoc)::acc) expr2 + | Pexp_open (overrideFlag, longidentLoc, expr2) -> + let openDoc = Doc.concat [ + Doc.text "open"; + printOverrideFlag overrideFlag; + Doc.space; + printLongidentLocation longidentLoc cmtTbl; + ] in + let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in + collectRows ((loc, openDoc)::acc) expr2 + | Pexp_sequence (expr1, expr2) -> + let exprDoc = + let doc = printExpression expr1 cmtTbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collectRows ((loc, exprDoc)::acc) expr2 + | Pexp_let (recFlag, valueBindings, expr2) -> + let loc = + let loc = match (valueBindings, List.rev valueBindings) with + | (vb::_, lastVb::_) -> {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} + | _ -> Location.none + in + match getFirstLeadingComment cmtTbl loc with + | None -> loc + | Some comment -> + let cmtLoc = Comment.loc comment in + {cmtLoc with loc_end = loc.loc_end} + in + let recFlag = match recFlag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let letDoc = printValueBindings ~recFlag valueBindings cmtTbl in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + begin match expr2.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> + List.rev ((loc, letDoc)::acc) + | _ -> + collectRows ((loc, letDoc)::acc) expr2 + end + | _ -> + let exprDoc = + let doc = printExpression expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, exprDoc)::acc) + in + let rows = collectRows [] expr in + let block = + printList + ~getLoc:fst + ~nodes:rows + ~print:(fun (_, doc) _ -> doc) + ~forceBreak:true + cmtTbl + in + Doc.breakableGroup ~forceBreak:true ( + if braces then + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.line; + block; + ] + ); + Doc.line; + Doc.rbrace; + ] + else block + ) + +(* + * // user types: + * let f = (a, b) => { a + b } + * + * // printer: everything is on one line + * let f = (a, b) => { a + b } + * + * // user types: over multiple lines + * let f = (a, b) => { + * a + b + * } + * + * // printer: over multiple lines + * let f = (a, b) => { + * a + b + * } + *) +and printBraces doc expr bracesLoc = + let overMultipleLines = + let open Location in + bracesLoc.loc_end.pos_lnum > bracesLoc.loc_start.pos_lnum + in + match expr.Parsetree.pexp_desc with + | Pexp_letmodule _ + | Pexp_letexception _ + | Pexp_let _ + | Pexp_open _ + | Pexp_sequence _ -> + (* already has braces *) + doc + | _ -> + Doc.breakableGroup ~forceBreak:overMultipleLines ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + if Parens.bracedExpr expr then addParens doc else doc; + ] + ); + Doc.softLine; + Doc.rbrace; + ] + ) + +and printOverrideFlag overrideFlag = match overrideFlag with + | Asttypes.Override -> Doc.text "!" + | Fresh -> Doc.nil + +and printDirectionFlag flag = match flag with + | Asttypes.Downto -> Doc.text " downto " + | Asttypes.Upto -> Doc.text " to " + +and printRecordRow (lbl, expr) cmtTbl = + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let doc = Doc.group (Doc.concat [ + printLidentPath lbl cmtTbl; + Doc.text ": "; + (let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ]) in + printComments doc cmtTbl cmtLoc + +and printBsObjectRow (lbl, expr) cmtTbl = + let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let lblDoc = + let doc = Doc.concat [ + Doc.text "\""; + printLongident lbl.txt; + Doc.text "\""; + ] in + printComments doc cmtTbl lbl.loc + in + let doc = Doc.concat [ + lblDoc; + Doc.text ": "; + (let doc = printExpressionWithComments expr cmtTbl in + match Parens.expr expr with + | Parens.Parenthesized -> addParens doc + | Braced braces -> printBraces doc expr braces + | Nothing -> doc); + ] in + printComments doc cmtTbl cmtLoc + +(* The optional loc indicates whether we need to print the attributes in + * relation to some location. In practise this means the following: + * `@attr type t = string` -> on the same line, print on the same line + * `@attr + * type t = string` -> attr is on prev line, print the attributes + * with a line break between, we respect the users' original layout *) +and printAttributes ?loc ?(inline=false) (attrs: Parsetree.attributes) cmtTbl = + match ParsetreeViewer.filterParsingAttrs attrs with + | [] -> Doc.nil + | attrs -> + let lineBreak = match loc with + | None -> Doc.line + | Some loc -> begin match List.rev attrs with + | ({loc = firstLoc}, _)::_ when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> + Doc.hardLine; + | _ -> Doc.line + end + in + Doc.concat [ + Doc.group (Doc.join ~sep:Doc.line (List.map (fun attr -> printAttribute attr cmtTbl) attrs)); + if inline then Doc.space else lineBreak; + ] + +and printPayload (payload : Parsetree.payload) cmtTbl = + match payload with + | PStr [] -> Doc.nil + | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> + let exprDoc = printExpressionWithComments expr cmtTbl in + let needsParens = match attrs with | [] -> false | _ -> true in + let shouldHug = ParsetreeViewer.isHuggableExpression expr in + if shouldHug then + Doc.concat [ + Doc.lparen; + printAttributes attrs cmtTbl; + if needsParens then addParens exprDoc else exprDoc; + Doc.rparen; + ] + else + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printAttributes attrs cmtTbl; + if needsParens then addParens exprDoc else exprDoc; + ] + ); + Doc.softLine; + Doc.rparen; + ] + | PStr [{pstr_desc = Pstr_value (_recFlag, _bindings)} as si] -> + addParens(printStructureItem si cmtTbl) + | PStr structure -> + addParens(printStructure structure cmtTbl) + | PTyp typ -> + Doc.concat [ + Doc.lparen; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + printTypExpr typ cmtTbl; + ]; + ); + Doc.softLine; + Doc.rparen; + ] + | PPat (pat, optExpr) -> + let whenDoc = match optExpr with + | Some expr -> + Doc.concat [ + Doc.line; + Doc.text "if "; + printExpressionWithComments expr cmtTbl; + ] + | None -> Doc.nil + in + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.text "? "; + printPattern pat cmtTbl; + whenDoc; + ] + ); + Doc.softLine; + Doc.rparen; + ] + | PSig signature -> + Doc.concat [ + Doc.lparen; + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + printSignature signature cmtTbl; + ]; + ); + Doc.softLine; + Doc.rparen; + ] + +and printAttribute ((id, payload) : Parsetree.attribute) cmtTbl = + Doc.group ( + Doc.concat [ + Doc.text "@"; + Doc.text (convertBsExternalAttribute id.txt); + printPayload payload cmtTbl + ] + ) + +and printModExpr modExpr cmtTbl = + let doc = match modExpr.pmod_desc with + | Pmod_ident longidentLoc -> + printLongidentLocation longidentLoc cmtTbl + | Pmod_structure [] -> + let shouldBreak = + modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum + in + Doc.breakableGroup ~forceBreak:shouldBreak ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printCommentsInside cmtTbl modExpr.pmod_loc; + ]; + ); + Doc.softLine; + Doc.rbrace; + ] + ) + | Pmod_structure structure -> + Doc.breakableGroup ~forceBreak:true ( + Doc.concat [ + Doc.lbrace; + Doc.indent ( + Doc.concat [ + Doc.softLine; + printStructure structure cmtTbl; + ]; + ); + Doc.softLine; + Doc.rbrace; + ] + ) + | Pmod_unpack expr -> + let shouldHug = match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint ( + {pexp_desc = Pexp_let _ }, + {ptyp_desc = Ptyp_package _packageType} + ) -> true + | _ -> false + in + let (expr, moduleConstraint) = match expr.pexp_desc with + | Pexp_constraint ( + expr, + {ptyp_desc = Ptyp_package packageType; ptyp_loc} + ) -> + let packageDoc = + let doc = printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl in + printComments doc cmtTbl ptyp_loc + in + let typeDoc = Doc.group (Doc.concat [ + Doc.text ":"; + Doc.indent ( + Doc.concat [ + Doc.line; + packageDoc + ] + ) + ]) in + (expr, typeDoc) + | _ -> (expr, Doc.nil) + in + let unpackDoc = Doc.group(Doc.concat [ + printExpressionWithComments expr cmtTbl; + moduleConstraint; + ]) in + Doc.group ( + Doc.concat [ + Doc.text "unpack("; + if shouldHug then unpackDoc + else + Doc.concat [ + Doc.indent ( + Doc.concat [ + Doc.softLine; + unpackDoc; + ] + ); + Doc.softLine; + ]; + Doc.rparen; + ] + ) + | Pmod_extension extension -> + printExtension ~atModuleLvl:false extension cmtTbl + | Pmod_apply _ -> + let (args, callExpr) = ParsetreeViewer.modExprApply modExpr in + let isUnitSugar = match args with + | [{pmod_desc = Pmod_structure []}] -> true + | _ -> false + in + let shouldHug = match args with + | [{pmod_desc = Pmod_structure _}] -> true + | _ -> false + in + Doc.group ( + Doc.concat [ + printModExpr callExpr cmtTbl; + if isUnitSugar then + printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl + else + Doc.concat [ + Doc.lparen; + if shouldHug then + printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl + else + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun modArg -> printModApplyArg modArg cmtTbl) args + ) + ] + ); + if not shouldHug then + Doc.concat [ + Doc.trailingComma; + Doc.softLine; + ] + else Doc.nil; + Doc.rparen; + ] + ] + ) + | Pmod_constraint (modExpr, modType) -> + Doc.concat [ + printModExpr modExpr cmtTbl; + Doc.text ": "; + printModType modType cmtTbl; + ] + | Pmod_functor _ -> + printModFunctor modExpr cmtTbl + in + printComments doc cmtTbl modExpr.pmod_loc + +and printModFunctor modExpr cmtTbl = + let (parameters, returnModExpr) = ParsetreeViewer.modExprFunctor modExpr in + (* let shouldInline = match returnModExpr.pmod_desc with *) + (* | Pmod_structure _ | Pmod_ident _ -> true *) + (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) + (* | _ -> false *) + (* in *) + let (returnConstraint, returnModExpr) = match returnModExpr.pmod_desc with + | Pmod_constraint (modExpr, modType) -> + let constraintDoc = + let doc = printModType modType cmtTbl in + if Parens.modExprFunctorConstraint modType then addParens doc else doc + in + let modConstraint = Doc.concat [ + Doc.text ": "; + constraintDoc; + ] in + (modConstraint, printModExpr modExpr cmtTbl) + | _ -> (Doc.nil, printModExpr returnModExpr cmtTbl) + in + let parametersDoc = match parameters with + | [(attrs, {txt = "*"}, None)] -> + Doc.group ( + Doc.concat [ + printAttributes attrs cmtTbl; + Doc.text "()" + ] + ) + | [([], {txt = lbl}, None)] -> Doc.text lbl + | parameters -> + Doc.group ( + Doc.concat [ + Doc.lparen; + Doc.indent ( + Doc.concat [ + Doc.softLine; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( + List.map (fun param -> printModFunctorParam param cmtTbl) parameters + ) + ] + ); + Doc.trailingComma; + Doc.softLine; + Doc.rparen; + ] + ) + in + Doc.group ( + Doc.concat [ + parametersDoc; + returnConstraint; + Doc.text " => "; + returnModExpr + ] + ) + +and printModFunctorParam (attrs, lbl, optModType) cmtTbl = + let cmtLoc = match optModType with + | None -> lbl.Asttypes.loc + | Some modType -> {lbl.loc with loc_end = + modType.Parsetree.pmty_loc.loc_end + } + in + let attrs = printAttributes attrs cmtTbl in + let lblDoc = + let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in + printComments doc cmtTbl lbl.loc + in + let doc = Doc.group ( + Doc.concat [ + attrs; + lblDoc; + (match optModType with + | None -> Doc.nil + | Some modType -> + Doc.concat [ + Doc.text ": "; + printModType modType cmtTbl + ]); + ] + ) in + printComments doc cmtTbl cmtLoc + +and printModApplyArg modExpr cmtTbl = + match modExpr.pmod_desc with + | Pmod_structure [] -> Doc.text "()" + | _ -> printModExpr modExpr cmtTbl + + +and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl = + let kind = match constr.pext_kind with + | Pext_rebind longident -> Doc.indent ( + Doc.concat [ + Doc.text " ="; + Doc.line; + printLongidentLocation longident cmtTbl; + ] + ) + | Pext_decl (Pcstr_tuple [], None) -> Doc.nil + | Pext_decl (args, gadt) -> + let gadtDoc = match gadt with + | Some typ -> Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl + ] + | None -> Doc.nil + in + Doc.concat [ + printConstructorArguments ~indent:false args cmtTbl; + gadtDoc + ] + in + let name = + printComments + (Doc.text constr.pext_name.txt) + cmtTbl + constr.pext_name.loc + in + let doc = Doc.group ( + Doc.concat [ + printAttributes constr.pext_attributes cmtTbl; + Doc.text "exception "; + name; + kind + ] + ) in + printComments doc cmtTbl constr.pext_loc + +and printExtensionConstructor (constr : Parsetree.extension_constructor) cmtTbl i = + let attrs = printAttributes constr.pext_attributes cmtTbl in + let bar = if i > 0 then Doc.text "| " + else Doc.ifBreaks (Doc.text "| ") Doc.nil + in + let kind = match constr.pext_kind with + | Pext_rebind longident -> Doc.indent ( + Doc.concat [ + Doc.text " ="; + Doc.line; + printLongidentLocation longident cmtTbl; + ] + ) + | Pext_decl (Pcstr_tuple [], None) -> Doc.nil + | Pext_decl (args, gadt) -> + let gadtDoc = match gadt with + | Some typ -> Doc.concat [ + Doc.text ": "; + printTypExpr typ cmtTbl; + ] + | None -> Doc.nil + in + Doc.concat [ + printConstructorArguments ~indent:false args cmtTbl; + gadtDoc + ] + in + let name = + printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc + in + Doc.concat [ + bar; + Doc.group ( + Doc.concat [ + attrs; + name; + kind; + ] + ) + ] + +let printImplementation ~width (s: Parsetree.structure) ~comments = + let cmtTbl = CommentTable.make () in + CommentTable.walkStructure s cmtTbl comments; + (* CommentTable.log cmtTbl; *) + let doc = printStructure s cmtTbl in + (* Doc.debug doc; *) + Doc.toString ~width doc ^ "\n" + +let printInterface ~width (s: Parsetree.signature) ~comments = + let cmtTbl = CommentTable.make () in + CommentTable.walkSignature s cmtTbl comments; + Doc.toString ~width (printSignature s cmtTbl) ^ "\n" diff --git a/analysis/src/vendor/res_outcome_printer/res_printer.mli b/analysis/src/vendor/res_outcome_printer/res_printer.mli new file mode 100644 index 000000000..bfd0cd4d1 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_printer.mli @@ -0,0 +1,20 @@ +val convertBsExternalAttribute : string -> string +val convertBsExtension : string -> string + +val printTypeParams : + (Parsetree.core_type * Asttypes.variance) list -> Res_comments_table.t -> Res_doc.t + +val printLongident : Longident.t -> Res_doc.t + +val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t + +val addParens : Res_doc.t -> Res_doc.t + +val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t + +val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t [@@live] + +val printImplementation : + width:int -> Parsetree.structure -> comments:Res_comment.t list -> string +val printInterface : + width:int -> Parsetree.signature -> comments:Res_comment.t list -> string diff --git a/analysis/src/vendor/res_outcome_printer/res_reporting.ml b/analysis/src/vendor/res_outcome_printer/res_reporting.ml new file mode 100644 index 000000000..f5bd4fe7a --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_reporting.ml @@ -0,0 +1,12 @@ +module Token = Res_token +module Grammar = Res_grammar + +type problem = + | Unexpected of Token.t [@live] + | Expected of {token: Token.t; pos: Lexing.position; context: Grammar.t option} [@live] + | Message of string [@live] + | Uident [@live] + | Lident [@live] + | Unbalanced of Token.t [@live] + +type parseError = Lexing.position * problem diff --git a/analysis/src/vendor/res_outcome_printer/res_scanner.ml b/analysis/src/vendor/res_outcome_printer/res_scanner.ml new file mode 100644 index 000000000..b6855f6ce --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_scanner.ml @@ -0,0 +1,716 @@ +module Diagnostics = Res_diagnostics +module Token = Res_token +module Comment = Res_comment + +type mode = Jsx | Diamond + +(* We hide the implementation detail of the scanner reading character. Our char +will also contain the special -1 value to indicate end-of-file. This isn't +ideal; we should clean this up *) +let hackyEOFChar = Char.unsafe_chr (-1) +type charEncoding = Char.t + +type t = { + filename: string; + src: string; + mutable err: + startPos: Lexing.position + -> endPos: Lexing.position + -> Diagnostics.category + -> unit; + mutable ch: charEncoding; (* current character *) + mutable offset: int; (* character offset *) + mutable lineOffset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; +} + +let setDiamondMode scanner = + scanner.mode <- Diamond::scanner.mode + +let setJsxMode scanner = + scanner.mode <- Jsx::scanner.mode + +let popMode scanner mode = + match scanner.mode with + | m::ms when m = mode -> + scanner.mode <- ms + | _ -> () + +let inDiamondMode scanner = match scanner.mode with + | Diamond::_ -> true + | _ -> false + +let inJsxMode scanner = match scanner.mode with + | Jsx::_ -> true + | _ -> false + +let position scanner = Lexing.{ + pos_fname = scanner.filename; + (* line number *) + pos_lnum = scanner.lnum; + (* offset of the beginning of the line (number + of characters between the beginning of the scanner and the beginning + of the line) *) + pos_bol = scanner.lineOffset; + (* [pos_cnum] is the offset of the position (number of + characters between the beginning of the scanner and the position). *) + pos_cnum = scanner.offset; +} + +(* Small debugging util +❯ echo 'let msg = "hello"' | ./lib/rescript.exe +let msg = "hello" +^-^ let 0-3 +let msg = "hello" + ^-^ msg 4-7 +let msg = "hello" + ^ = 8-9 +let msg = "hello" + ^-----^ string "hello" 10-17 +let msg = "hello" + ^ eof 18-18 +let msg = "hello" +*) +let _printDebug ~startPos ~endPos scanner token = + let open Lexing in + print_string scanner.src; + print_string ((String.make [@doesNotRaise]) startPos.pos_cnum ' '); + print_char '^'; + (match endPos.pos_cnum - startPos.pos_cnum with + | 0 -> + if token = Token.Eof then () + else assert false + | 1 -> () + | n -> ( + print_string ((String.make [@doesNotRaise]) (n - 2) '-'); + print_char '^'; + )); + print_char ' '; + print_string (Res_token.toString token); + print_char ' '; + print_int startPos.pos_cnum; + print_char '-'; + print_int endPos.pos_cnum; + print_endline "" +[@@live] + +let next scanner = + let nextOffset = scanner.offset + 1 in + (match scanner.ch with + | '\n' -> + scanner.lineOffset <- nextOffset; + scanner.lnum <- scanner.lnum + 1; + (* What about CRLF (\r + \n) on windows? + * \r\n will always be terminated by a \n + * -> we can just bump the line count on \n *) + | _ -> ()); + if nextOffset < String.length scanner.src then ( + scanner.offset <- nextOffset; + scanner.ch <- String.unsafe_get scanner.src scanner.offset; + ) else ( + scanner.offset <- String.length scanner.src; + scanner.ch <- hackyEOFChar + ) + +let next2 scanner = + next scanner; + next scanner + +let next3 scanner = + next scanner; + next scanner; + next scanner + +let peek scanner = + if scanner.offset + 1 < String.length scanner.src then + String.unsafe_get scanner.src (scanner.offset + 1) + else + hackyEOFChar + +let peek2 scanner = + if scanner.offset + 2 < String.length scanner.src then + String.unsafe_get scanner.src (scanner.offset + 2) + else + hackyEOFChar + +let make ~filename src = + { + filename; + src = src; + err = (fun ~startPos:_ ~endPos:_ _ -> ()); + ch = if src = "" then hackyEOFChar else String.unsafe_get src 0; + offset = 0; + lineOffset = 0; + lnum = 1; + mode = []; + } + + +(* generic helpers *) + +let isWhitespace ch = + match ch with + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false + +let rec skipWhitespace scanner = + if isWhitespace scanner.ch then ( + next scanner; + skipWhitespace scanner + ) + +let digitValue ch = + match ch with + | '0'..'9' -> (Char.code ch) - 48 + | 'a'..'f' -> + (Char.code ch) - (Char.code 'a') + 10 + | 'A'..'F' -> + (Char.code ch) + 32 - (Char.code 'a') + 10 + | _ -> 16 (* larger than any legal value *) + +let rec skipLowerCaseChars scanner = + match scanner.ch with + | 'a'..'z' -> next scanner; skipLowerCaseChars scanner + | _ -> () + + +(* scanning helpers *) + +let scanIdentifier scanner = + let startOff = scanner.offset in + let rec skipGoodChars scanner = + match scanner.ch with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> + next scanner; + skipGoodChars scanner + | _ -> () + in + skipGoodChars scanner; + let str = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in + if '{' == scanner.ch && str = "list" then begin + next scanner; + (* TODO: this isn't great *) + Token.lookupKeyword "list{" + end + else Token.lookupKeyword str + +let scanDigits scanner ~base = + if base <= 10 then + let rec loop scanner = + match scanner.ch with + | '0'..'9' | '_' -> next scanner; loop scanner + | _ -> () + in loop scanner + else + let rec loop scanner = + match scanner.ch with + (* hex *) + | '0'..'9' | 'a'..'f' | 'A'..'F' | '_' -> next scanner; loop scanner + | _ -> () + in loop scanner + +(* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *) +let scanNumber scanner = + let startOff = scanner.offset in + + (* integer part *) + let base = match scanner.ch with + | '0' -> + (match peek scanner with + | 'x' | 'X' -> next2 scanner; 16 + | 'o' | 'O' -> next2 scanner; 8 + | 'b' | 'B' -> next2 scanner; 2 + | _ -> next scanner; 8) + | _ -> 10 + in + scanDigits scanner ~base; + + (* *) + let isFloat = if '.' == scanner.ch then ( + next scanner; + scanDigits scanner ~base; + true + ) else + false + in + + (* exponent part *) + let isFloat = + match scanner.ch with + | 'e' | 'E' | 'p' | 'P' -> + (match peek scanner with + | '+' | '-' -> next2 scanner + | _ -> next scanner); + scanDigits scanner ~base; + true + | _ -> isFloat + in + let literal = + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) + in + + (* suffix *) + let suffix = + match scanner.ch with + | 'n' -> + let msg = + "Unsupported number type (nativeint). Did you mean `" + ^ literal + ^ "`?" + in + let pos = position scanner in + scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg); + next scanner; + Some 'n' + | 'g'..'z' | 'G'..'Z' as ch -> + next scanner; + Some ch + | _ -> + None + in + if isFloat then + Token.Float {f = literal; suffix} + else + Token.Int {i = literal; suffix} + +let scanExoticIdentifier scanner = + (* TODO: are we disregarding the current char...? Should be a quote *) + next scanner; + let buffer = Buffer.create 20 in + let startPos = position scanner in + + let rec scan () = + match scanner.ch with + | '"' -> next scanner + | '\n' | '\r' -> + (* line break *) + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.message "A quoted identifier can't contain line breaks."); + next scanner + | ch when ch == hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?") + | ch -> + Buffer.add_char buffer ch; + next scanner; + scan () + in + scan (); + (* TODO: do we really need to create a new buffer instead of substring once? *) + Token.Lident (Buffer.contents buffer) + +let scanStringEscapeSequence ~startPos scanner = + let scan ~n ~base ~max = + let rec loop n x = + if n == 0 then x + else + let d = digitValue scanner.ch in + if d >= base then + let pos = position scanner in + let msg = + if scanner.ch == hackyEOFChar then "unclosed escape sequence" + else "unknown escape sequence" + in + scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); + -1 + else + let () = next scanner in + loop (n - 1) (x * base + d) + in + let x = loop n 0 in + if x > max then + let pos = position scanner in + let msg = "invalid escape sequence (value too high)" in + scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) + in + match scanner.ch with + (* \ already consumed *) + | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> + next scanner + | '0'..'9' -> + (* decimal *) + scan ~n:3 ~base:10 ~max:255 + | 'o' -> + (* octal *) + next scanner; + scan ~n:3 ~base:8 ~max:255 + | 'x' -> + (* hex *) + next scanner; + scan ~n:2 ~base:16 ~max:255 + | _ -> + (* unknown escape sequence + * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) + (* + let pos = position scanner in + let msg = + if ch == -1 then "unclosed escape sequence" + else "unknown escape sequence" + in + scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) + *) + () + +let scanString scanner = + (* assumption: we've just matched a quote *) + + let startPosWithQuote = position scanner in + next scanner; + let firstCharOffset = scanner.offset in + + let rec scan () = + match scanner.ch with + | '"' -> + let lastCharOffset = scanner.offset in + next scanner; + (String.sub [@doesNotRaise]) scanner.src firstCharOffset (lastCharOffset - firstCharOffset) + | '\\' -> + let startPos = position scanner in + next scanner; + scanStringEscapeSequence ~startPos scanner; + scan () + | ch when ch == hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; + (String.sub [@doesNotRaise]) scanner.src firstCharOffset (scanner.offset - firstCharOffset) + | _ -> + next scanner; + scan () + in + Token.String (scan ()) + +let scanEscape scanner = + let convertNumber scanner ~n ~base = + let x = ref 0 in + for _ = n downto 1 do + let d = digitValue scanner.ch in + x := (!x * base) + d; + next scanner + done; + (Char.chr [@doesNotRaise]) !x + in + (* let offset = scanner.offset in *) + let c = match scanner.ch with + | '0'..'9' -> convertNumber scanner ~n:3 ~base:10 + | 'b' -> next scanner; '\008' + | 'n' -> next scanner; '\010' + | 'r' -> next scanner; '\013' + | 't' -> next scanner; '\009' + | 'x' -> next scanner; convertNumber scanner ~n:2 ~base:16 + | 'o' -> next scanner; convertNumber scanner ~n:3 ~base:8 + | ch -> next scanner; ch + in + next scanner; (* Consume \' *) + (* TODO: do we know it's \' ? *) + Token.Character c + +let scanSingleLineComment scanner = + let startOff = scanner.offset in + let startPos = position scanner in + let rec skip scanner = + match scanner.ch with + | '\n' | '\r' -> () + | ch when ch == hackyEOFChar -> () + | _ -> + next scanner; + skip scanner + in + skip scanner; + let endPos = position scanner in + Token.Comment ( + Comment.makeSingleLineComment + ~loc:(Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false}) + ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff)) + ) + +let scanMultiLineComment scanner = + (* assumption: we're only ever using this helper in `scan` after detecting a comment *) + let contentStartOff = scanner.offset + 2 in + let startPos = position scanner in + let rec scan ~depth = + (* invariant: depth > 0 right after this match. See assumption *) + match scanner.ch, peek scanner with + | '/', '*' -> + next2 scanner; + scan ~depth:(depth + 1) + | '*', '/' -> + next2 scanner; + if depth > 1 then scan ~depth:(depth - 1) + | ch, _ when ch == hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedComment + | _ -> + next scanner; + scan ~depth + in + scan ~depth:0; + Token.Comment ( + Comment.makeMultiLineComment + ~loc:(Location.{loc_start = startPos; loc_end = (position scanner); loc_ghost = false}) + ((String.sub [@doesNotRaise]) scanner.src contentStartOff (scanner.offset - 2 - contentStartOff)) + ) + +let scanTemplateLiteralToken scanner = + let startOff = scanner.offset in + + (* if starting } here, consume it *) + if scanner.ch == '}' then next scanner; + + let startPos = position scanner in + + let rec scan () = + match scanner.ch with + | '`' -> + next scanner; + Token.TemplateTail( + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 1 - startOff) + ) + | '$' -> + (match peek scanner with + | '{' -> + next2 scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 2 - startOff) + in + Token.TemplatePart contents + | _ -> + next scanner; + scan()) + | '\\' -> + (match peek scanner with + | '`' | '\\' | '$' + | '\n' | '\r' -> + (* line break *) + next2 scanner; + scan () + | _ -> + next scanner; + scan ()) + | ch when ch = hackyEOFChar -> + let endPos = position scanner in + scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; + Token.TemplateTail( + (String.sub [@doesNotRaise]) scanner.src startOff (max (scanner.offset - 1 - startOff) 0) + ) + | _ -> + next scanner; + scan () + in + let token = scan () in + let endPos = position scanner in + (startPos, endPos, token) + +let rec scan scanner = + skipWhitespace scanner; + let startPos = position scanner in + + let token = match scanner.ch with + (* peeking 0 char *) + | 'A'..'Z' | 'a'..'z' -> scanIdentifier scanner + | '0'..'9' -> scanNumber scanner + | '`' -> next scanner; Token.Backtick + | '~' -> next scanner; Token.Tilde + | '?' -> next scanner; Token.Question + | ';' -> next scanner; Token.Semicolon + | '(' -> next scanner; Token.Lparen + | ')' -> next scanner; Token.Rparen + | '[' -> next scanner; Token.Lbracket + | ']' -> next scanner; Token.Rbracket + | '{' -> next scanner; Token.Lbrace + | '}' -> next scanner; Token.Rbrace + | ',' -> next scanner; Token.Comma + | '"' -> scanString scanner + + (* peeking 1 char *) + | '_' -> + (match peek scanner with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> scanIdentifier scanner + | _ -> next scanner; Token.Underscore) + | '#' -> + (match peek scanner with + | '=' -> next2 scanner; Token.HashEqual + | _ -> next scanner; Token.Hash) + | '*' -> + (match peek scanner with + | '*' -> next2 scanner; Token.Exponentiation + | '.' -> next2 scanner; Token.AsteriskDot + | _ -> next scanner; Token.Asterisk) + | '@' -> + (match peek scanner with + | '@' -> next2 scanner; Token.AtAt + | _ -> next scanner; Token.At) + | '%' -> + (match peek scanner with + | '%' -> next2 scanner; Token.PercentPercent + | _ -> next scanner; Token.Percent) + | '|' -> + (match peek scanner with + | '|' -> next2 scanner; Token.Lor + | '>' -> next2 scanner; Token.BarGreater + | _ -> next scanner; Token.Bar) + | '&' -> + (match peek scanner with + | '&' -> next2 scanner; Token.Land + | _ -> next scanner; Token.Band) + | ':' -> + (match peek scanner with + | '=' -> next2 scanner; Token.ColonEqual + | '>' -> next2 scanner; Token.ColonGreaterThan + | _ -> next scanner; Token.Colon) + | '\\' -> next scanner; scanExoticIdentifier scanner + | '/' -> + (match peek scanner with + | '/' -> next2 scanner; scanSingleLineComment scanner + | '*' -> scanMultiLineComment scanner + | '.' -> next2 scanner; Token.ForwardslashDot + | _ -> next scanner; Token.Forwardslash) + | '-' -> + (match peek scanner with + | '.' -> next2 scanner; Token.MinusDot + | '>' -> next2 scanner; Token.MinusGreater + | _ -> next scanner; Token.Minus) + | '+' -> + (match peek scanner with + | '.' -> next2 scanner; Token.PlusDot + | '+' -> next2 scanner; Token.PlusPlus + | '=' -> next2 scanner; Token.PlusEqual + | _ -> next scanner; Token.Plus) + | '>' -> + (match peek scanner with + | '=' when not (inDiamondMode scanner) -> next2 scanner; Token.GreaterEqual + | _ -> next scanner; Token.GreaterThan) + | '<' when not (inJsxMode scanner) -> + (match peek scanner with + | '=' -> next2 scanner; Token.LessEqual + | _ -> next scanner; Token.LessThan) + (* special handling for JSX < *) + | '<' -> + (* Imagine the following:
< + * < indicates the start of a new jsx-element, the parser expects + * the name of a new element after the < + * Example:
+ * This signals a closing element. To simulate the two-token lookahead, + * the next scanner; Token.LessThanSlash + | '=' -> next scanner; Token.LessEqual + | _ -> Token.LessThan) + + (* peeking 2 chars *) + | '.' -> + (match peek scanner, peek2 scanner with + | '.', '.' -> next3 scanner; Token.DotDotDot + | '.', _ -> next2 scanner; Token.DotDot + | _ -> next scanner; Token.Dot) + | '\'' -> + (match peek scanner, peek2 scanner with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) + next scanner; SingleQuote + | '\\', _ -> next2 scanner; scanEscape scanner + | ch, '\'' -> next3 scanner; Token.Character ch + | _ -> next scanner; SingleQuote) + | '!' -> + (match peek scanner, peek2 scanner with + | '=', '=' -> next3 scanner; Token.BangEqualEqual + | '=', _ -> next2 scanner; Token.BangEqual + | _ -> next scanner; Token.Bang) + | '=' -> + (match peek scanner, peek2 scanner with + | '=', '=' -> next3 scanner; Token.EqualEqualEqual + | '=', _ -> next2 scanner; Token.EqualEqual + | '>', _ -> next2 scanner; Token.EqualGreater + | _ -> next scanner; Token.Equal) + + (* special cases *) + | ch when ch == hackyEOFChar -> next scanner; Token.Eof + | ch -> + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let endPos = position scanner in + scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); + let (_, _, token) = scan scanner in + token + in + let endPos = position scanner in + (* _printDebug ~startPos ~endPos scanner token; *) + (startPos, endPos, token) + + +(* misc helpers used elsewhere *) + +(* Imagine:
< + * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and + * determines the correct token to disambiguate *) +let reconsiderLessThan scanner = + (* < consumed *) + skipWhitespace scanner; + if scanner.ch == '/' then + let () = next scanner in + Token.LessThanSlash + else + Token.LessThan + +(* If an operator has whitespace around both sides, it's a binary operator *) +(* TODO: this helper seems out of place *) +let isBinaryOp src startCnum endCnum = + if startCnum == 0 then false + else begin + (* we're gonna put some assertions and invariant checks here because this is + used outside of the scanner's normal invariant assumptions *) + assert (endCnum >= 0); + assert (startCnum > 0 && startCnum < String.length src); + let leftOk = isWhitespace (String.unsafe_get src (startCnum - 1)) in + (* we need some stronger confidence that endCnum is ok *) + let rightOk = endCnum >= String.length src || isWhitespace (String.unsafe_get src endCnum) in + leftOk && rightOk + end + +(* Assume `{` consumed, advances the scanner towards the ends of Reason quoted strings. (for conversion) + * In {| foo bar |} the scanner will be advanced until after the `|}` *) +let tryAdvanceQuotedString scanner = + let rec scanContents tag = + match scanner.ch with + | '|' -> + next scanner; + (match scanner.ch with + | 'a'..'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let suffix = + (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) + in begin + if tag = suffix then ( + if scanner.ch = '}' then + next scanner + else + scanContents tag + ) else + scanContents tag + end + | '}' -> next scanner + | _ -> scanContents tag) + | ch when ch == hackyEOFChar -> + (* TODO: why is this place checking EOF and not others? *) + () + | _ -> + next scanner; + scanContents tag + in + match scanner.ch with + | 'a'..'z' -> + let startOff = scanner.offset in + skipLowerCaseChars scanner; + let tag = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in + if scanner.ch = '|' then scanContents tag + | '|' -> + scanContents "" + | _ -> () diff --git a/analysis/src/vendor/res_outcome_printer/res_scanner.mli b/analysis/src/vendor/res_outcome_printer/res_scanner.mli new file mode 100644 index 000000000..777d171e6 --- /dev/null +++ b/analysis/src/vendor/res_outcome_printer/res_scanner.mli @@ -0,0 +1,35 @@ +type mode = Jsx | Diamond + +type charEncoding + +type t = { + filename: string; + src: string; + mutable err: + startPos: Lexing.position + -> endPos: Lexing.position + -> Res_diagnostics.category + -> unit; + mutable ch: charEncoding; (* current character *) + mutable offset: int; (* character offset *) + mutable lineOffset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; +} + +val make: filename:string -> string -> t + +(* TODO: make this a record *) +val scan: t -> (Lexing.position * Lexing.position * Res_token.t) + +val isBinaryOp: string -> int -> int -> bool + +val setJsxMode: t -> unit +val setDiamondMode: t -> unit +val popMode: t -> mode -> unit + +val reconsiderLessThan: t -> Res_token.t + +val scanTemplateLiteralToken: t -> (Lexing.position * Lexing.position * Res_token.t) + +val tryAdvanceQuotedString: t -> unit diff --git a/analysis/tests/src/Parser.res b/analysis/tests/src/Parser.res new file mode 100644 index 000000000..c5f548da8 --- /dev/null +++ b/analysis/tests/src/Parser.res @@ -0,0 +1,85 @@ +module M = { + module C = Component +} + +let _c = + +let _mc = + +let _d =
+ +let _d2 = +
+ {React.string("abc")} +
{React.string("abc")}
+ {React.string("abc")} + {React.string("abc")} +
+ +type pair<'x, 'y> = ('x, 'y) + +type looooooooooooooooooooooooooooooooooooooong_int = int + +type looooooooooooooooooooooooooooooooooooooong_string = string + +type pairIntString = list< + pair< + looooooooooooooooooooooooooooooooooooooong_int, + looooooooooooooooooooooooooooooooooooooong_string, + >, +> + +let _ = 3 < 4 || 3 > 4 + +module type MT = { + module DDF: { + + } +} + +module DDF: MT = { + module DDF = { + + } +} + +module XX = { + module YY = { + type t = int + } +} + +open XX.YY + +type tt = t + +// ^par + +module T = { + type someRecord<'typeParameter> = { + someField: int, + someOtherField: string, + theParam: 'typeParameter, + } + + type someEnum = A | B | C +} + +let foo = x => x.T.someField + +let add = (~hello as x, ~world) => x + world + +let _ = add(~hello=3) + +let _ =
+ +module SomeComponent = { + module Nested = { + @react.component + let make = (~children) => { + <> {children} + } + } +} + +let _ =
diff --git a/analysis/tests/src/expected/Debug.res.txt b/analysis/tests/src/expected/Debug.res.txt index f63aaa815..180b6861e 100644 --- a/analysis/tests/src/expected/Debug.res.txt +++ b/analysis/tests/src/expected/Debug.res.txt @@ -4,7 +4,7 @@ Dependencies: @rescript/react Source directories: tests/node_modules/@rescript/react/src tests/node_modules/@rescript/react/src/legacy Source files: tests/node_modules/@rescript/react/src/React.res tests/node_modules/@rescript/react/src/ReactDOM.res tests/node_modules/@rescript/react/src/ReactDOMServer.res tests/node_modules/@rescript/react/src/ReactDOMStyle.res tests/node_modules/@rescript/react/src/ReactEvent.res tests/node_modules/@rescript/react/src/ReactEvent.resi tests/node_modules/@rescript/react/src/ReactTestUtils.res tests/node_modules/@rescript/react/src/ReactTestUtils.resi tests/node_modules/@rescript/react/src/RescriptReactErrorBoundary.res tests/node_modules/@rescript/react/src/RescriptReactErrorBoundary.resi tests/node_modules/@rescript/react/src/RescriptReactRouter.res tests/node_modules/@rescript/react/src/RescriptReactRouter.resi tests/node_modules/@rescript/react/src/legacy/ReactDOMRe.res tests/node_modules/@rescript/react/src/legacy/ReasonReact.res Source directories: tests/src tests/src/expected -Source files: tests/src/Auto.res tests/src/CompletePrioritize1.res tests/src/CompletePrioritize2.res tests/src/Completion.res tests/src/Component.res tests/src/Component.resi tests/src/Cross.res tests/src/Debug.res tests/src/Definition.res tests/src/DefinitionWithInterface.res tests/src/DefinitionWithInterface.resi tests/src/Div.res tests/src/Fragment.res tests/src/Hover.res tests/src/Jsx.res tests/src/Jsx.resi tests/src/LongIdentTest.res tests/src/Obj.res tests/src/Patterns.res tests/src/RecModules.res tests/src/RecordCompletion.res tests/src/References.res tests/src/ReferencesWithInterface.res tests/src/ReferencesWithInterface.resi tests/src/Rename.res tests/src/RenameWithInterface.res tests/src/RenameWithInterface.resi tests/src/TableclothMap.ml tests/src/TableclothMap.mli tests/src/TypeDefinition.res +Source files: tests/src/Auto.res tests/src/CompletePrioritize1.res tests/src/CompletePrioritize2.res tests/src/Completion.res tests/src/Component.res tests/src/Component.resi tests/src/Cross.res tests/src/Debug.res tests/src/Definition.res tests/src/DefinitionWithInterface.res tests/src/DefinitionWithInterface.resi tests/src/Div.res tests/src/Fragment.res tests/src/Hover.res tests/src/Jsx.res tests/src/Jsx.resi tests/src/LongIdentTest.res tests/src/Obj.res tests/src/Parser.res tests/src/Patterns.res tests/src/RecModules.res tests/src/RecordCompletion.res tests/src/References.res tests/src/ReferencesWithInterface.res tests/src/ReferencesWithInterface.resi tests/src/Rename.res tests/src/RenameWithInterface.res tests/src/RenameWithInterface.resi tests/src/TableclothMap.ml tests/src/TableclothMap.mli tests/src/TypeDefinition.res Impl cmt:tests/lib/bs/src/Auto.cmt res:tests/src/Auto.res Impl cmt:tests/lib/bs/src/CompletePrioritize1.cmt res:tests/src/CompletePrioritize1.res Impl cmt:tests/lib/bs/src/CompletePrioritize2.cmt res:tests/src/CompletePrioritize2.res @@ -20,6 +20,7 @@ Impl cmt:tests/lib/bs/src/Hover.cmt res:tests/src/Hover.res IntfAndImpl cmti:tests/lib/bs/src/Jsx.cmti resi:tests/src/Jsx.resi cmt:tests/lib/bs/src/Jsx.cmt res:tests/src/Jsx.res Impl cmt:tests/lib/bs/src/LongIdentTest.cmt res:tests/src/LongIdentTest.res Impl cmt:tests/lib/bs/src/Obj.cmt res:tests/src/Obj.res +Impl cmt:tests/lib/bs/src/Parser.cmt res:tests/src/Parser.res Impl cmt:tests/lib/bs/src/Patterns.cmt res:tests/src/Patterns.res Impl cmt:tests/lib/bs/src/RecModules.cmt res:tests/src/RecModules.res Impl cmt:tests/lib/bs/src/RecordCompletion.cmt res:tests/src/RecordCompletion.res diff --git a/analysis/tests/src/expected/Parser.res.txt b/analysis/tests/src/expected/Parser.res.txt new file mode 100644 index 000000000..9b19c2199 --- /dev/null +++ b/analysis/tests/src/expected/Parser.res.txt @@ -0,0 +1,99 @@ +Parse tests/src/Parser.res +structure items:22 diagnostics:0 +Lident: M (0,7) Namespace +Lident: C (1,9) Namespace +Lident: Component (1,13) Namespace +Lident: Component (4,10) Namespace +Variable: _c (4,4)->(4,6) +Ldot: M (6,11) Namespace +Lident: C (6,13) Namespace +Variable: _mc (6,4)->(6,7) +Lident: div (8,10) Variable +Variable: _d (8,4)->(8,6) +Lident: div (11,3) Variable +Lident: div (16,4) Variable +JsxTag >: (11,6) +JsxTag >: (16,7) +Ldot: React (12,5) Namespace +Lident: string (12,11) Variable +Lident: div (13,5) Variable +Lident: div (13,34) Variable +JsxTag >: (13,8) +JsxTag >: (13,37) +Ldot: React (13,11) Namespace +Lident: string (13,17) Variable +Ldot: React (14,5) Namespace +Lident: string (14,11) Variable +Ldot: React (15,5) Namespace +Lident: string (15,11) Variable +Variable: _d2 (10,4)->(10,7) +Type: pair (18,5)->(18,9) +Type: looooooooooooooooooooooooooooooooooooooong_int (20,5)->(20,51) +Type: int (20,54)->(20,57) +Type: looooooooooooooooooooooooooooooooooooooong_string (22,5)->(22,54) +Type: string (22,57)->(22,63) +Type: pairIntString (24,5)->(24,18) +Type: list (24,21)->(24,25) +TypeArg: (25,2)->(28,3) +Type: pair (25,2)->(25,6) +TypeArg: (26,4)->(26,50) +TypeArg: (27,4)->(27,53) +Type: looooooooooooooooooooooooooooooooooooooong_int (26,4)->(26,50) +Type: looooooooooooooooooooooooooooooooooooooong_string (27,4)->(27,53) +BinaryExp: (31,14)->(31,16) +BinaryExp: (31,10)->(31,11) +BinaryExp: (31,19)->(31,20) +Lident: MT (33,12) Type +Lident: DDF (34,9) Namespace +Lident: DDF (39,7) Namespace +Lident: MT (39,12) Type +Lident: DDF (40,9) Namespace +Lident: XX (45,7) Namespace +Lident: YY (46,9) Namespace +Type: t (47,9)->(47,10) +Type: int (47,13)->(47,16) +Ldot: XX (51,5) Namespace +Lident: YY (51,8) Namespace +Type: tt (53,5)->(53,7) +Type: t (53,10)->(53,11) +Lident: T (57,7) Namespace +Type: someRecord (58,7)->(58,17) +Lident: someField (59,4) Property +Type: int (59,15)->(59,18) +Lident: someOtherField (60,4) Property +Type: string (60,20)->(60,26) +Lident: theParam (61,4) Property +Type: someEnum (64,7)->(64,15) +Lident: A (64,18) EnumMember +Lident: B (64,22) EnumMember +Lident: C (64,26) EnumMember +Ldot: T (67,17) Namespace +Lident: someField (67,19) Property +Lident: x (67,15) Variable +Variable: x (67,10)->(67,11) +Variable: foo (67,4)->(67,7) +BinaryExp: (69,37)->(69,38) +Lident: x (69,35) Variable +Lident: world (69,39) Variable +Variable: world (69,24)->(69,30) +Variable: x (69,21)->(69,22) +Variable: add (69,4)->(69,7) +Lident: add (71,8) Variable +Lident: div (73,9) Variable +Lident: div (73,36) Variable +JsxTag >: (73,24) +JsxTag >: (73,39) +Lident: div (73,27) Variable +Lident: SomeComponent (75,7) Namespace +Lident: Nested (76,9) Namespace +Lident: children (79,10) Variable +Variable: children (78,16)->(78,25) +Variable: make (78,8)->(78,12) +Ldot: SomeComponent (84,9) Namespace +Lident: Nested (84,23) Namespace +Ldot: SomeComponent (84,41) Namespace +Lident: Nested (84,55) Namespace +JsxTag >: (84,29) +JsxTag >: (84,61) +Lident: div (84,32) Variable + diff --git a/grammars/rescript.tmLanguage.json b/grammars/rescript.tmLanguage.json index 5932d7eae..232ec7fa1 100644 --- a/grammars/rescript.tmLanguage.json +++ b/grammars/rescript.tmLanguage.json @@ -15,7 +15,15 @@ }, "RE_KEYWORDS": { "name": "keyword.control", - "match": "\\b(and|as|assert|constraint|downto|else|exception|external|false|for|if|in|include|lazy|let|module|mutable|of|open|rec|switch|to|true|try|type|when|while|with)\\b" + "match": "\\b(and|as|assert|constraint|downto|else|exception|external|false|for|if|in|include|lazy|module|mutable|of|open|rec|switch|to|true|try|type|when|while|with)\\b" + }, + "RE_CONSTANTS_BOOL": { + "name": "constant.language.boolean", + "match": "\\b(false|true)\\b" + }, + "RE_LET": { + "name": "keyword", + "match": "\\b(let)\\b" }, "RE_LITERAL": { "name": "constant.language", @@ -91,6 +99,9 @@ "patterns": [ { "include": "#RE_KEYWORDS" + }, + { + "include": "#RE_LET" } ] }, @@ -98,6 +109,9 @@ "patterns": [ { "include": "#RE_LITERAL" + }, + { + "include": "#RE_CONSTANTS_BOOL" } ] }, @@ -147,13 +161,13 @@ "begin": "\\$\\{", "beginCaptures": { "0": { - "name": "punctuation.section.interpolation.begin" + "name": "punctuation.definition.template-expression.begin" } }, "end": "\\}", "endCaptures": { "0": { - "name": "punctuation.section.interpolation.end" + "name": "punctuation.definition.template-expression.end" } }, "patterns": [ @@ -199,6 +213,14 @@ } ] }, + "defaultIdIsVariable": { + "patterns": [ + { + "match": "[A-Za-z][A-Za-z0-9]*", + "name": "variable" + } + ] + }, "number": { "patterns": [ { @@ -322,22 +344,48 @@ "jsx": { "patterns": [ { - "match": "<>||/>" + "match": "<>||/>", + "name": "punctuation.definition.tag" }, { "match": " void = (_) => { }; +let send: (msg: m.Message) => void = (_) => {}; interface CreateInterfaceRequestParams { uri: string; } -let createInterfaceRequest = - new v.RequestType< - CreateInterfaceRequestParams, - string, - void>("rescript-vscode.create_interface"); +let createInterfaceRequest = new v.RequestType< + CreateInterfaceRequestParams, + string, + void +>("rescript-vscode.create_interface"); interface OpenCompiledFileParams { uri: string; @@ -66,9 +65,8 @@ let sendUpdatedDiagnostics = () => { path.join(projectRootPath, c.compilerLogPartialPath), { encoding: "utf-8" } ); - let { done, result: filesAndErrors } = utils.parseCompilerLogOutput( - content - ); + let { done, result: filesAndErrors } = + utils.parseCompilerLogOutput(content); // diff Object.keys(filesAndErrors).forEach((file) => { @@ -290,7 +288,12 @@ function typeDefinition(msg: p.RequestMessage) { let filePath = fileURLToPath(params.textDocument.uri); let response = utils.runAnalysisCommand( filePath, - ["typeDefinition", filePath, params.position.line, params.position.character], + [ + "typeDefinition", + filePath, + params.position.line, + params.position.character, + ], msg ); return response; @@ -323,7 +326,7 @@ function prepareRename(msg: p.RequestMessage): m.ResponseMessage { ); let result: p.Range | null = null; if (locations !== null) { - locations.forEach(loc => { + locations.forEach((loc) => { if ( path.normalize(fileURLToPath(loc.uri)) === path.normalize(fileURLToPath(params.textDocument.uri)) @@ -337,14 +340,14 @@ function prepareRename(msg: p.RequestMessage): m.ResponseMessage { end.line >= pos.line ) { result = loc.range; - }; + } } }); - }; + } return { jsonrpc: c.jsonrpcVersion, id: msg.id, - result + result, }; } @@ -352,23 +355,22 @@ function rename(msg: p.RequestMessage) { // https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_rename let params = msg.params as p.RenameParams; let filePath = fileURLToPath(params.textDocument.uri); - let documentChanges: - | (p.RenameFile | p.TextDocumentEdit)[] - | null = utils.runAnalysisAfterSanityCheck(filePath, [ + let documentChanges: (p.RenameFile | p.TextDocumentEdit)[] | null = + utils.runAnalysisAfterSanityCheck(filePath, [ "rename", filePath, params.position.line, params.position.character, - params.newName + params.newName, ]); let result: WorkspaceEdit | null = null; if (documentChanges !== null) { result = { documentChanges }; - }; + } let response: m.ResponseMessage = { jsonrpc: c.jsonrpcVersion, id: msg.id, - result + result, }; return response; } @@ -385,6 +387,23 @@ function documentSymbol(msg: p.RequestMessage) { return response; } +function semanticTokens(msg: p.RequestMessage) { + // https://microsoft.github.io/language-server-protocol/specifications/specification-current/#textDocument_semanticTokens + let params = msg.params as p.SemanticTokensParams; + let filePath = fileURLToPath(params.textDocument.uri); + let code = getOpenedFileContent(params.textDocument.uri); + let extension = path.extname(params.textDocument.uri); + let tmpname = utils.createFileInTempDir(extension); + fs.writeFileSync(tmpname, code, { encoding: "utf-8" }); + let response = utils.runAnalysisCommand( + filePath, + ["semanticTokens", tmpname], + msg + ); + fs.unlink(tmpname, () => null); + return response; +} + function completion(msg: p.RequestMessage) { let params = msg.params as p.ReferenceParams; let filePath = fileURLToPath(params.textDocument.uri); @@ -739,6 +758,23 @@ function onMessage(msg: m.Message) { // disabled right now until we use the parser to show non-stale symbols per keystroke // documentSymbolProvider: true, completionProvider: { triggerCharacters: [".", ">", "@", "~", '"'] }, + semanticTokensProvider: { + legend: { + tokenTypes: [ + "keyword", + "variable", + "type", + "jsx-tag", + "namespace", + "enumMember", + "property", + ], + tokenModifiers: [], + }, + documentSelector: null, + // TODO: Support range for full, and add delta support + full: true, + }, }, }; let response: m.ResponseMessage = { @@ -797,6 +833,8 @@ function onMessage(msg: m.Message) { send(documentSymbol(msg)); } else if (msg.method === p.CompletionRequest.method) { send(completion(msg)); + } else if (msg.method === p.SemanticTokensRequest.method) { + send(semanticTokens(msg)); } else if (msg.method === p.DocumentFormattingRequest.method) { let responses = format(msg); responses.forEach((response) => send(response));