diff --git a/jscomp/napkin/.gitignore b/jscomp/napkin/.gitignore new file mode 100644 index 0000000000..51b2fc78a7 --- /dev/null +++ b/jscomp/napkin/.gitignore @@ -0,0 +1,3 @@ +# place holder not tracking napkin files +*.ml +*.mli \ No newline at end of file diff --git a/jscomp/napkin/napkin_ast_conversion.ml b/jscomp/napkin/napkin_ast_conversion.ml deleted file mode 100644 index 6cb0197c39..0000000000 --- a/jscomp/napkin/napkin_ast_conversion.ml +++ /dev/null @@ -1,531 +0,0 @@ - -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 = 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 normalize = - let open Ast_mapper in - { default_mapper with - 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 - | _ -> - default_mapper.pat mapper p - end; - 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_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")) - }, - (default_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 (operand, (Location.mknoloc (Longident.Lident "contents"))) - } - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}} as op, - [Asttypes.Nolabel, lhs; Nolabel, ({pexp_desc = Pexp_constant (Pconst_string (txt, None))} as stringExpr)] - ) -> - let ident = { - Parsetree.pexp_loc = stringExpr.pexp_loc; - pexp_attributes = []; - pexp_desc = Pexp_ident (Location.mkloc (Longident.Lident txt) stringExpr.pexp_loc) - } in - { - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - pexp_desc = Pexp_apply (op, [Asttypes.Nolabel, lhs; Nolabel, ident]) - } - | 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 ( - default_mapper.expr mapper condition, - default_mapper.expr mapper thenExpr, - (Some (default_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 (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 (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/jscomp/napkin/napkin_ast_conversion.mli b/jscomp/napkin/napkin_ast_conversion.mli deleted file mode 100644 index f8f0e3b815..0000000000 --- a/jscomp/napkin/napkin_ast_conversion.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* The purpose of this module is to convert a parsetree coming from the reason - * or ocaml parser, into something consumable by the napkinscript 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 napkin ternaries *) -val structure: Parsetree.structure -> Parsetree.structure -val signature: Parsetree.signature -> Parsetree.signature diff --git a/jscomp/napkin/napkin_ast_debugger.ml b/jscomp/napkin/napkin_ast_debugger.ml deleted file mode 100644 index ed57b84214..0000000000 --- a/jscomp/napkin/napkin_ast_debugger.ml +++ /dev/null @@ -1,1235 +0,0 @@ -module Doc = Napkin_doc - -let printEngine = Napkin_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 = Napkin_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 \ No newline at end of file diff --git a/jscomp/napkin/napkin_ast_debugger.mli b/jscomp/napkin/napkin_ast_debugger.mli deleted file mode 100644 index 339adaf29b..0000000000 --- a/jscomp/napkin/napkin_ast_debugger.mli +++ /dev/null @@ -1,8 +0,0 @@ - - - -val printEngine : Napkin_driver.printEngine - - -val sexpPrintEngine : Napkin_driver.printEngine - \ No newline at end of file diff --git a/jscomp/napkin/napkin_binary_driver.ml b/jscomp/napkin/napkin_binary_driver.ml deleted file mode 100644 index 883dea041c..0000000000 --- a/jscomp/napkin/napkin_binary_driver.ml +++ /dev/null @@ -1,12 +0,0 @@ -let printEngine = Napkin_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/jscomp/napkin/napkin_binary_driver.mli b/jscomp/napkin/napkin_binary_driver.mli deleted file mode 100644 index 5b9fe9252c..0000000000 --- a/jscomp/napkin/napkin_binary_driver.mli +++ /dev/null @@ -1 +0,0 @@ -val printEngine : Napkin_driver.printEngine diff --git a/jscomp/napkin/napkin_character_codes.ml b/jscomp/napkin/napkin_character_codes.ml deleted file mode 100644 index 5de247c5ae..0000000000 --- a/jscomp/napkin/napkin_character_codes.ml +++ /dev/null @@ -1,160 +0,0 @@ -let eof = -1 - -let space = 0x0020 -let newline = 0x0A (* \n *) [@@live] -let lineFeed = 0x0A (* \n *) -let carriageReturn = 0x0D (* \r *) -let lineSeparator = 0x2028 -let paragraphSeparator = 0x2029 - -let tab = 0x09 - -let bang = 0x21 -let dot = 0x2E -let colon = 0x3A -let comma = 0x2C -let backtick = 0x60 -(* let question = 0x3F *) -let semicolon = 0x3B -let underscore = 0x5F -let singleQuote = 0x27 -let doubleQuote = 0x22 -let equal = 0x3D -let bar = 0x7C -let tilde = 0x7E -let question = 0x3F -let ampersand = 0x26 -let at = 0x40 -let dollar = 0x24 -let percent = 0x25 - -let lparen = 0x28 -let rparen = 0x29 -let lbracket = 0x5B -let rbracket = 0x5D -let lbrace = 0x7B -let rbrace = 0x7D - -let forwardslash = 0x2F (* / *) -let backslash = 0x5C (* \ *) - -let greaterThan = 0x3E -let hash = 0x23 -let lessThan = 0x3C - -let minus = 0x2D -let plus = 0x2B -let asterisk = 0x2A - -let _0 = 0x30 -let _1 = 0x31 [@@live] -let _2 = 0x32 [@@live] -let _3 = 0x33 [@@live] -let _4 = 0x34 [@@live] -let _5 = 0x35 [@@live] -let _6 = 0x36 [@@live] -let _7 = 0x37 [@@live] -let _8 = 0x38 [@@live] -let _9 = 0x39 - -module Lower = struct - let a = 0x61 - let b = 0x62 - let c = 0x63 [@@live] - let d = 0x64 [@@live] - let e = 0x65 - let f = 0x66 - let g = 0x67 - let h = 0x68 [@@live] - let i = 0x69 [@@live] - let j = 0x6A [@@live] - let k = 0x6B [@@live] - let l = 0x6C [@@live] - let m = 0x6D [@@live] - let n = 0x6E - let o = 0x6F - let p = 0x70 - let q = 0x71 [@@live] - let r = 0x72 - let s = 0x73 [@@live] - let t = 0x74 - let u = 0x75 [@@live] - let v = 0x76 [@@live] - let w = 0x77 [@@live] - let x = 0x78 - let y = 0x79 [@@live] - let z = 0x7A -end - -module Upper = struct - let a = 0x41 - (* let b = 0x42 *) - let c = 0x43 [@@live] - let d = 0x44 [@@live] - let e = 0x45 [@@live] - let f = 0x46 [@@live] - let g = 0x47 - let h = 0x48 [@@live] - let i = 0x49 [@@live] - let j = 0x4A [@@live] - let k = 0x4B [@@live] - let l = 0x4C [@@live] - let m = 0x4D [@@live] - let b = 0x4E [@@live] - let o = 0x4F [@@live] - let p = 0x50 [@@live] - let q = 0x51 [@@live] - let r = 0x52 [@@live] - let s = 0x53 [@@live] - let t = 0x54 [@@live] - let u = 0x55 [@@live] - let v = 0x56 [@@live] - let w = 0x57 [@@live] - let x = 0x58 [@@live] - let y = 0x59 [@@live] - let z = 0x5a -end - -(* returns lower-case ch, ch should be ascii *) -let lower ch = - (* if ch >= Lower.a && ch <= Lower.z then ch else ch + 32 *) - 32 lor ch - -let isLetter ch = - Lower.a <= ch && ch <= Lower.z || - Upper.a <= ch && ch <= Upper.z - -let isUpperCase ch = - Upper.a <= ch && ch <= Upper.z - -let isDigit ch = _0 <= ch && ch <= _9 - -let isHex ch = - (_0 <= ch && ch <= _9) || - (Lower.a <= (lower ch) && (lower ch) <= Lower.f) - - (* - // ES5 7.3: - // The ECMAScript line terminator characters are listed in Table 3. - // Table 3: Line Terminator Characters - // Code Unit Value Name Formal Name - // \u000A Line Feed - // \u000D Carriage Return - // \u2028 Line separator - // \u2029 Paragraph separator - // Only the characters in Table 3 are treated as line terminators. Other new line or line - // breaking characters are treated as white space but not as line terminators. -*) -let isLineBreak ch = - ch == lineFeed - || ch == carriageReturn - || ch == lineSeparator - || ch == paragraphSeparator - -let digitValue ch = - if _0 <= ch && ch <= _9 then - ch - 48 - else if Lower.a <= (lower ch) && (lower ch) <= Lower.f then - (lower ch) - Lower.a + 10 - else - 16 (* larger than any legal value *) \ No newline at end of file diff --git a/jscomp/napkin/napkin_comment.ml b/jscomp/napkin/napkin_comment.ml deleted file mode 100644 index a582dcdae2..0000000000 --- a/jscomp/napkin/napkin_comment.ml +++ /dev/null @@ -1,73 +0,0 @@ -type style = - | SingleLine - | MultiLine - -let styleToString s = match s with - | SingleLine -> "SingleLine" - | MultiLine -> "MultiLine" - -type t = { - txt: string; - style: style; - loc: Location.t; - mutable prevTokEndPos: Lexing.position; -} - -let loc t = t.loc -let txt t = t.txt -let prevTokEndPos t = t.prevTokEndPos - -let setPrevTokEndPos t pos = - t.prevTokEndPos <- pos - -let isSingleLineComment t = match t.style with - | SingleLine -> true - | MultiLine -> false - -let toString t = - Format.sprintf - "(txt: %s\nstyle: %s\nlines: %d-%d)" - t.txt - (styleToString t.style) - t.loc.loc_start.pos_lnum - t.loc.loc_end.pos_lnum - -let makeSingleLineComment ~loc txt = { - txt; - loc; - style = SingleLine; - prevTokEndPos = Lexing.dummy_pos; -} - -let makeMultiLineComment ~loc txt = { - txt; - loc; - style = MultiLine; - prevTokEndPos = Lexing.dummy_pos; -} - -let fromOcamlComment ~loc ~txt ~prevTokEndPos = { - txt; - loc; - style = MultiLine; - prevTokEndPos = prevTokEndPos -} - -let trimSpaces s = - let len = String.length s in - if len = 0 then s - else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' then ( - let b = Bytes.of_string s in - let i = ref 0 in - while !i < len && (Bytes.unsafe_get b !i) = ' ' do - incr i - done; - let j = ref (len - 1) in - while !j >= !i && (Bytes.unsafe_get b !j) = ' ' do - decr j - done; - if !j >= !i then - (Bytes.sub [@doesNotRaise]) b !i (!j - !i + 1) |> Bytes.to_string - else - "" - ) else s \ No newline at end of file diff --git a/jscomp/napkin/napkin_comment.mli b/jscomp/napkin/napkin_comment.mli deleted file mode 100644 index 7fdaa0459c..0000000000 --- a/jscomp/napkin/napkin_comment.mli +++ /dev/null @@ -1,17 +0,0 @@ -type t - -val toString: t -> string - -val loc: t -> Location.t -val txt: t -> string -val prevTokEndPos: t -> Lexing.position - -val setPrevTokEndPos: t -> Lexing.position -> unit - -val isSingleLineComment: t -> bool - -val makeSingleLineComment: loc:Location.t -> string -> t -val makeMultiLineComment: loc:Location.t -> string -> t -val fromOcamlComment: - loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t -val trimSpaces: string -> string \ No newline at end of file diff --git a/jscomp/napkin/napkin_comments_table.ml b/jscomp/napkin/napkin_comments_table.ml deleted file mode 100644 index def0de13a3..0000000000 --- a/jscomp/napkin/napkin_comments_table.ml +++ /dev/null @@ -1,1867 +0,0 @@ -module Comment = Napkin_comment -module Doc = Napkin_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 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 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}}} - | _ -> vb - in - let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in - let exprLoc = vb.Parsetree.pvb_expr.pexp_loc 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 pattern = expr -> pattern and expr on the same line *) - (* if patternLoc.loc_end.pos_lnum == exprLoc.loc_start.pos_lnum then ( *) - let (afterPat, surroundingExpr) = - partitionAdjacentTrailing patternLoc trailing - in - attach t.trailing patternLoc afterPat; - let (beforeExpr, insideExpr, afterExpr) = - partitionByLoc surroundingExpr exprLoc in - if isBlockExpr vb.pvb_expr then ( - walkExpr vb.pvb_expr t (List.concat [beforeExpr; insideExpr; afterExpr]) - ) else ( - attach t.leading exprLoc beforeExpr; - walkExpr vb.Parsetree.pvb_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, 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"}, - 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 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 Napkin_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) -> - let loc = match expr.Parsetree.pexp_attributes with - | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> - expr.pexp_loc - in - 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 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 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 (leading, inside, trailing) = partitionByLoc trailing 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) -> typexpr.Parsetree.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/jscomp/napkin/napkin_core.ml b/jscomp/napkin/napkin_core.ml deleted file mode 100644 index dccd14e05a..0000000000 --- a/jscomp/napkin/napkin_core.ml +++ /dev/null @@ -1,5993 +0,0 @@ -module Doc = Napkin_doc -module Grammar = Napkin_grammar -module Token = Napkin_token -module Diagnostics = Napkin_diagnostics -module CommentTable = Napkin_comments_table -module NapkinscriptPrinter = Napkin_printer -module Scanner = Napkin_scanner -module JsFfi = Napkin_js_ffi -module Parser = Napkin_parser - -let mkLoc startLoc endLoc = Location.{ - loc_start = startLoc; - loc_end = endLoc; - loc_ghost = false; -} - -module Recover = struct - (* type action = unit option None is abort, Some () is retry *) - - let defaultExpr () = - let id = Location.mknoloc "napkinscript.exprhole" in - Ast_helper.Exp.mk (Pexp_extension (id, PStr [])) - - let defaultType () = - let id = Location.mknoloc "napkinscript.typehole" in - Ast_helper.Typ.extension (id, PStr []) - - let defaultPattern () = - let id = Location.mknoloc "napkinscript.patternhole" in - Ast_helper.Pat.extension (id, PStr []) - (* Ast_helper.Pat.any () *) - - let defaultModuleExpr () = Ast_helper.Mod.structure [] - let defaultModuleType () = Ast_helper.Mty.signature [] - - 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." -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 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 - | _ -> assert false - -let rec goToClosing closingToken state = - match (state.Parser.token, closingToken) with - | (Rparen, Token.Rparen) | (Rbrace, Rbrace) | (Rbracket, Rbracket) -> - Parser.next state; - () - | (Token.Lbracket | Lparen | Lbrace | List) 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 - | Rparen -> - Parser.next state; - begin match state.Parser.token with - | Colon when not inTernary -> true - | 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 - - -(* {"foo": bar} -> Js.t({. foo: bar}) - * {.. "foo": bar} -> Js.t({.. foo: bar}) - * {..} -> Js.t({..}) *) -let makeBsObjType ~attrs ~loc ~closed rows = - let obj = Ast_helper.Typ.object_ ~loc rows closed in - let jsDotTCtor = - Location.mkloc (Longident.Ldot (Longident.Lident "Js", "t")) loc - in - Ast_helper.Typ.constr ~loc ~attrs jsDotTCtor [obj] - -(* 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 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 -> - Parser.err p (Diagnostics.message msg); - Parser.next p; - ("_", mkLoc startPos p.prevEndPos) - -let parseHashIdent ~startPos p = - Parser.expect Hash p; - 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:false 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 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 loop i = - if i = len then - () - else - let c = String.unsafe_get s i in - match c with - | '\\' as c -> - let nextIx = i + 1 in - if nextIx < len then - let nextChar = String.unsafe_get s nextIx in - begin match nextChar with - (* this is interesting: - * let x = "foo\ - * bar" - * The `\` escapes the newline, as if there was nothing here. - * Essentialy transforming this piece of code in `let x = "foobar"` - * - * What is even more interesting is that any space or tabs after the - * escaped newline are also dropped. - * let x = "foo\ - * bar" - * is the same as `let x = "foobar"` - *) - | '\010' | '\013' -> - let i = ref (nextIx + 1) in - while !i < len && ( - let c = String.unsafe_get s !i in - c = ' ' || c = '\t' - ) do - incr i - done; - loop !i - | 'n' -> - Buffer.add_char b '\010'; - loop (nextIx + 1) - | 'r' -> - Buffer.add_char b '\013'; - loop (nextIx + 1) - | 'b' -> - Buffer.add_char b '\008'; - loop (nextIx + 1) - | 't' -> - Buffer.add_char b '\009'; - loop (nextIx + 1) - | '\\' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | ' ' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | '\'' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | '\"' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | '0' .. '9' -> - if nextIx + 2 < len then - let c0 = nextChar in - let c1 = (String.unsafe_get s (nextIx + 1)) in - let c2 = (String.unsafe_get s (nextIx + 2)) in - let c = - 100 * (Char.code c0 - 48) + - 10 * (Char.code c1 - 48) + - (Char.code c2 - 48) - in - if (c < 0 || c > 255) then ( - Buffer.add_char b '\\'; - Buffer.add_char b c0; - Buffer.add_char b c1; - Buffer.add_char b c2; - loop (nextIx + 3) - ) else ( - Buffer.add_char b (Char.unsafe_chr c); - loop (nextIx + 3) - ) - else ( - Buffer.add_char b '\\'; - Buffer.add_char b nextChar; - loop (nextIx + 1) - ) - | 'o' -> - if nextIx + 3 < len then - let c0 = (String.unsafe_get s (nextIx + 1)) in - let c1 = (String.unsafe_get s (nextIx + 2)) in - let c2 = (String.unsafe_get s (nextIx + 3)) in - let c = - 64 * (Char.code c0 - 48) + - 8 * (Char.code c1 - 48) + - (Char.code c2 - 48) - in - if (c < 0 || c > 255) then ( - Buffer.add_char b '\\'; - Buffer.add_char b '0'; - Buffer.add_char b c0; - Buffer.add_char b c1; - Buffer.add_char b c2; - loop (nextIx + 4) - ) else ( - Buffer.add_char b (Char.unsafe_chr c); - loop (nextIx + 4) - ) - else ( - Buffer.add_char b '\\'; - Buffer.add_char b nextChar; - loop (nextIx + 1) - ) - | 'x' as c -> - if nextIx + 2 < len then - let c0 = (String.unsafe_get s (nextIx + 1)) in - let c1 = (String.unsafe_get s (nextIx + 2)) in - let c = (16 * (hexValue c0)) + (hexValue c1) in - if (c < 0 || c > 255) then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'x'; - Buffer.add_char b c0; - Buffer.add_char b c1; - loop (nextIx + 3) - ) else ( - Buffer.add_char b (Char.unsafe_chr c); - loop (nextIx + 3) - ) - else ( - Buffer.add_char b '\\'; - Buffer.add_char b c; - loop (nextIx + 2) - ) - | _ -> - Buffer.add_char b c; - Buffer.add_char b nextChar; - loop (nextIx + 1) - end - else ( - Buffer.add_char b c; - () - ) - | c -> - Buffer.add_char b c; - loop (i + 1) - in - loop 0; - Buffer.contents b - -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) - | 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 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) - | _ -> - 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) - | _ -> - 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 - | 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; - Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) - | 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) = 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 - match p.token with - | As -> (* {bar as baz} -> {bar: baz} *) - Parser.next p; - let (name, loc) = parseLident p in - let var = Location.mkloc name loc in - let newNameOfLabel = Ast_helper.Pat.var ~loc var in - (label, newNameOfLabel) - | _ -> - (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 = - parseCommaDelimitedRegion p - ~grammar:Grammar.PatternList - ~closing:Rparen - ~f:parseConstrainedPatternRegion - in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.tuple ~loc ~attrs (first::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 - | [{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 ?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 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.Optional _ as lbl -> lbl - | Asttypes.Nolabel -> Asttypes.Nolabel - 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 - begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart with - | None -> - Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); - 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 -> - Parser.next p; - let stringEnd = p.prevEndPos in - Parser.expect Rbracket p; - let rbracket = p.prevEndPos in - let e = - let identLoc = mkLoc stringStart stringEnd in - let loc = mkLoc lbracket rbracket in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "##") loc)) - [Nolabel, expr; Nolabel, (Ast_helper.Exp.ident ~loc:identLoc (Location.mkloc (Longident.Lident 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; - 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 - Parser.eatBreadcrumb p; - 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 identifiers 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 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 loop acc p = - let startPos = p.Parser.startPos in - match p.Parser.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 - Scanner.setTemplateMode p.scanner; - Parser.expect Rbrace p; - 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 - loop next p - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - acc - in - Scanner.setTemplateMode p.scanner; - Parser.expect Backtick p; - let startPos = p.Parser.startPos in - match p.Parser.token with - | TemplateTail txt -> - let loc = mkLoc startPos p.endPos in - Parser.next p; - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) - | TemplatePart txt -> - let constantLoc = mkLoc startPos p.endPos in - Parser.next p; - let expr = parseExprBlock p in - let fullLoc = mkLoc startPos p.prevEndPos in - Scanner.setTemplateMode p.scanner; - Parser.expect Rbrace p; - 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 - loop next p - | 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) "; - NapkinscriptPrinter.printExpression arrow1 CommentTable.empty; - Doc.line; - Doc.text "2) "; - NapkinscriptPrinter.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; - NapkinscriptPrinter.addParens (NapkinscriptPrinter.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 = - let pat = parsePattern p in - 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 rdOffset = p.scanner.rdOffset 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.rdOffset <- rdOffset; - 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:false p in - Location.mkloc (Longident.Ldot (longident.txt, "createElement")) longident.loc - | _ -> - let msg = "A jsx name should start with a lowercase or uppercase identifier, 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 - {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 = - Parser.leaveBreadcrumb p Grammar.JsxAttribute; - 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.mknoloc (Longident.Lident name)) 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 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 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 - | 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 "bs.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 -> - parseFirstClassModuleExpr ~startPos 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 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; - parseIfLetExpr startPos p - | _ -> - 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 - | To -> Asttypes.Upto - | 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.expect For p; - 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 - | _ -> - let pat = parsePattern p in - 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 - | _ -> - parseForRest false (parsePattern p) startPos p - -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 -> - 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; - let lhs = parsePattern p in - 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; - None - -and parsePatternMatching p = - Parser.leaveBreadcrumb p Grammar.PatternMatching; - 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 - let startPos = p.Parser.startPos in - Parser.next(p); - begin match p.token with - (* apply(.) *) - | Rparen -> - let loc = mkLoc startPos p.prevEndPos in - let unitExpr = Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) 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 - ] - | 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 = - parseCommaDelimitedRegion - p ~grammar:Grammar.ExprList ~closing:Rparen ~f:parseConstrainedExprRegion - in - Parser.expect Rparen p; - Ast_helper.Exp.tuple ~loc:(mkLoc startPos p.prevEndPos) (first::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) = parseLident 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 -> - parseBsObjectType ~attrs p - | token -> - 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 - | 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 parseBsObjectType ~attrs p = - 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 fields = - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - makeBsObjType ~attrs ~loc ~closed:closedFlag fields - -(* 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 - Parser.expect ~grammar:Grammar.TypeExpression Colon 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 - | Lident _ -> - let (name, loc) = parseLident p in - begin match p.token with - | Colon -> - let () = - let error = Diagnostics.message - ("Parameter names start with a `~`, like: ~" ^ 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 - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parseTypExpr ~alias:false ~es6Arrow:false p 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 - Ast_helper.Typ.arrow ~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 = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p - in - Parser.expect Rparen p; - let tupleLoc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc (first::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; - NapkinscriptPrinter.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)) - | _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 = makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields 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 = makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields 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 _ - * - * 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) = parseLident 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) - (* TODO: should we try parsing lident as 'ident ? *) - | _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 [ - NapkinscriptPrinter.printLongident parent.Location.txt; - NapkinscriptPrinter.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.endPos 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 parseRecordOrBsObjectDecl 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 = - makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields - |> 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 = - makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields |> 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) = parseRecordOrBsObjectDecl 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 - Parser.expect Bar p; - [Parsetree.Rinherit typ; parseTagSpec p] - -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 -> - parseRecordOrBsObjectDecl 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) - | _ -> - let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in - TypeDef {recFlag; types = typeDefs} - -and parsePrimitive p = - match p.Parser.token with - | String s -> Parser.next p; Some s - | _ -> None - -and parsePrimitives p = - match (parseRegion ~grammar:Grammar.Primitive ~f:parsePrimitive p) with - | [] -> - let msg = "An external definition should have at least one primitive. Example: \"setTimeout\"" in - Parser.err p (Diagnostics.message msg); - [] - | primitives -> primitives - -(* external value-name : typexp = external-declaration *) -and parseExternalDef ~attrs p = - let startPos = p.Parser.startPos in - 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 - Parser.expect Equal p; - let prim = parsePrimitives p 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 - | _ -> - 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 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 -> - let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - 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 - | _ -> None - -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) - | _ -> - 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 - 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 - | 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 -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - exit (-1) (* TODO: handle this case *) - -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 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.next p; - begin match p.Parser.token with - | Uident _ -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.module_ ~loc modDecl) - | Rec -> - let recModule = parseRecModuleSpec ~attrs ~startPos p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.rec_module ~loc recModule) - | Typ -> - Some (parseModuleTypeDeclaration ~attrs ~startPos p) - | _t -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - 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 - | _ -> - None - -(* 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 p = - let startPos = p.Parser.startPos in - 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.next p; - begin match p.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - Parser.expect Rparen p; - Parsetree.PTyp typ - | Question -> - Parser.next p; - let pattern = parsePattern p in - let expr = match p.token with - | When -> - Parser.next p; - Some (parseExpr p) - | _ -> - None - in - Parser.expect Rparen p; - Parsetree.PPat (pattern, expr) - | _ -> - let items = parseDelimitedRegion - ~grammar:Grammar.Structure - ~closing:Rparen - ~f:parseStructureItemRegion - p - in - Parser.expect Rparen p; - Parsetree.PStr items - end - | _ -> Parsetree.PStr [] - -(* type attribute = string loc * payload *) -and parseAttribute p = - match p.Parser.token with - | At -> - Parser.next p; - let attrId = parseAttributeId 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 = - Parser.expect AtAt p; - let attrId = parseAttributeId 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 = - if moduleLanguage then - Parser.expect PercentPercent p - else - Parser.expect Percent p; - let attrId = parseAttributeId p in - let payload = parsePayload p in - (attrId, payload) diff --git a/jscomp/napkin/napkin_core.mli b/jscomp/napkin/napkin_core.mli deleted file mode 100644 index 9129c9aa4a..0000000000 --- a/jscomp/napkin/napkin_core.mli +++ /dev/null @@ -1,4 +0,0 @@ -val parseImplementation: - Napkin_parser.t -> Parsetree.structure -val parseSpecification: - Napkin_parser.t -> Parsetree.signature \ No newline at end of file diff --git a/jscomp/napkin/napkin_diagnostics.ml b/jscomp/napkin/napkin_diagnostics.ml deleted file mode 100644 index c133c116fe..0000000000 --- a/jscomp/napkin/napkin_diagnostics.ml +++ /dev/null @@ -1,194 +0,0 @@ -module Reporting = Napkin_reporting -module Grammar = Napkin_grammar -module Token = Napkin_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 int - -type t = { - filename: string; - startPos: Lexing.position; - endPos: Lexing.position; - category: category; -} - -type report = t list - -(* TODO: add json here *) -type reportStyle = - | Pretty - | Plain - -let parseReportStyle txt = match (String.lowercase_ascii txt) with - | "plain" -> Plain - | _ -> Pretty - -let defaultUnexpected token = - "I'm not sure what to parse here when looking at \"" ^ (Token.toString token) ^ "\"." - -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 identifier 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 an lowercased identifier like `name` 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 - | 94 (* ^ *) -> - "Hmm, not sure what I should do here with this character.\nIf you're trying to deref an expression, use `foo.contents` instead." - | _ -> - "Hmm, I have no idea what this character means…" - 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) -> - "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 - | _ -> - (* 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 toPlainString t buffer = - Buffer.add_string buffer t.filename; - Buffer.add_char buffer '('; - Buffer.add_string buffer (string_of_int t.startPos.pos_cnum); - Buffer.add_char buffer ','; - Buffer.add_string buffer (string_of_int t.endPos.pos_cnum); - Buffer.add_char buffer ')'; - Buffer.add_char buffer ':'; - Buffer.add_string buffer (explain t) - -let toString t src = - let open Lexing in - let startchar = t.startPos.pos_cnum - t.startPos.pos_bol in - let endchar = t.endPos.pos_cnum - t.startPos.pos_cnum + startchar in - let locationInfo = - Printf.sprintf (* ReasonLanguageServer requires the following format *) - "File \"%s\", line %d, characters %d-%d:" - t.filename - t.startPos.pos_lnum - startchar - endchar - in - let code = - let missing = match t.category with - | Expected {token = t} -> - Some (String.length (Token.toString t)) - | _ -> None - in - Reporting.renderCodeContext ~missing src t.startPos t.endPos - in - let explanation = explain t in - Printf.sprintf "%s\n\n%s\n\n%s\n\n" locationInfo code explanation - -let make ~filename ~startPos ~endPos category = { - filename; - startPos; - endPos; - category -} - -let stringOfReport ~style diagnostics src = - match style with - | Pretty -> - List.fold_left (fun report diagnostic -> - report ^ (toString diagnostic src) ^ "\n" - ) "\n" (List.rev diagnostics) - | Plain -> - let buffer = Buffer.create 100 in - List.iter (fun diagnostic -> - toPlainString diagnostic buffer; - Buffer.add_char buffer '\n'; - ) diagnostics; - Buffer.contents buffer - -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 \ No newline at end of file diff --git a/jscomp/napkin/napkin_diagnostics.mli b/jscomp/napkin/napkin_diagnostics.mli deleted file mode 100644 index aec9502843..0000000000 --- a/jscomp/napkin/napkin_diagnostics.mli +++ /dev/null @@ -1,27 +0,0 @@ -module Token = Napkin_token -module Grammar = Napkin_grammar -type t -type category -type report - -type reportStyle = Pretty | Plain -val parseReportStyle: string -> reportStyle - -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: int -> category -val message: string -> category - -val make: - filename: string - -> startPos: Lexing.position - -> endPos: Lexing.position - -> category - -> t - -val stringOfReport: style:reportStyle -> t list -> string -> string \ No newline at end of file diff --git a/jscomp/napkin/napkin_doc.ml b/jscomp/napkin/napkin_doc.ml deleted file mode 100644 index e7e838318a..0000000000 --- a/jscomp/napkin/napkin_doc.ml +++ /dev/null @@ -1,311 +0,0 @@ -module MiniBuffer = Napkin_minibuffer -type mode = Break | Flat - -type lineStyle = - | Classic (* fits? -> replace with space *) - | Soft (* fits? -> replaced with nothing *) - | Hard (* always included, forces breaks in parents *) - -type t = - | Nil - | Text of string - | Concat of t list - | Indent of t - | IfBreaks of {yes: t; no: t} - | LineSuffix of t - | LineBreak of lineStyle - | Group of {shouldBreak: bool; doc: t} - | CustomLayout of t list - | BreakParent - -let nil = Nil -let line = LineBreak Classic -let hardLine = LineBreak Hard -let softLine = LineBreak Soft -let text s = Text s -let concat l = Concat l -let indent d = Indent d -let ifBreaks t f = IfBreaks {yes = t; no = f} -let lineSuffix d = LineSuffix d -let group d = Group {shouldBreak = false; doc = d} -let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} -let customLayout gs = CustomLayout gs -let breakParent = BreakParent - -let space = Text " " -let comma = Text "," -let dot = Text "." -let dotdot = Text ".." -let dotdotdot = Text "..." -let lessThan = Text "<" -let greaterThan = Text ">" -let lbrace = Text "{" -let rbrace = Text "}" -let lparen = Text "(" -let rparen = Text ")" -let lbracket = Text "[" -let rbracket = Text "]" -let question = Text "?" -let tilde = Text "~" -let equal = Text "=" -let trailingComma = IfBreaks {yes = comma; no = nil} -let doubleQuote = Text "\"" - -let propagateForcedBreaks doc = - let rec walk doc = match doc with - | Text _ | Nil | LineSuffix _ -> - (false, doc) - | BreakParent -> - (true, Nil) - | LineBreak Hard -> - (true, doc) - | LineBreak (Classic | Soft) -> - (false, doc) - | Indent children -> - let (childForcesBreak, newChildren) = walk children in - (childForcesBreak, Indent newChildren) - | IfBreaks {yes = trueDoc; no = falseDoc} -> - let (falseForceBreak, falseDoc) = walk falseDoc in - if falseForceBreak then - let (_, trueDoc) = walk trueDoc in - (true, trueDoc) - else - let forceBreak, trueDoc = walk trueDoc in - (forceBreak, IfBreaks {yes = trueDoc; no = falseDoc}) - | Group {shouldBreak = forceBreak; doc = children} -> - let (childForcesBreak, newChildren) = walk children in - let shouldBreak = forceBreak || childForcesBreak in - (shouldBreak, Group {shouldBreak; doc = newChildren}) - | Concat children -> - let (forceBreak, newChildren) = List.fold_left (fun (forceBreak, newChildren) child -> - let (childForcesBreak, newChild) = walk child in - (forceBreak || childForcesBreak, newChild::newChildren) - ) (false, []) children - in - (forceBreak, Concat (List.rev newChildren)) - | CustomLayout children -> - (* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here *) - let children = match walk (Concat children) with - | (_, Concat children) -> children - | _ -> assert false - in - (false, CustomLayout children) - in - let (_, processedDoc) = walk doc in - processedDoc - -let join ~sep docs = - let rec loop acc sep docs = - match docs with - | [] -> List.rev acc - | [x] -> List.rev (x::acc) - | x::xs -> loop (sep::x::acc) sep xs - in - Concat(loop [] sep docs) - -let rec fits w doc = match doc with - | _ when w < 0 -> false - | [] -> true - | (_ind, _mode, Text txt)::rest -> fits (w - String.length txt) rest - | (ind, mode, Indent doc)::rest -> fits w ((ind + 2, mode, doc)::rest) - | (_ind, Flat, LineBreak break)::rest -> - if break = Hard then true - else - let w = if break = Classic then w - 1 else w in - fits w rest - | (_ind, _mode, Nil)::rest -> fits w rest - | (_ind, Break, LineBreak _break)::_rest -> true - | (ind, mode, Group {shouldBreak = forceBreak; doc})::rest -> - let mode = if forceBreak then Break else mode in - fits w ((ind, mode, doc)::rest) - | (ind, mode, IfBreaks {yes = breakDoc; no = flatDoc})::rest -> - if mode = Break then - fits w ((ind, mode, breakDoc)::rest) - else - fits w ((ind, mode, flatDoc)::rest) - | (ind, mode, Concat docs)::rest -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - fits w (List.append ops rest) - (* | (_ind, _mode, Cursor)::rest -> fits w rest *) - | (_ind, _mode, LineSuffix _)::rest -> fits w rest - | (_ind, _mode, BreakParent)::rest -> fits w rest - | (ind, mode, CustomLayout (hd::_))::rest -> - (* TODO: if we have nested custom layouts, what we should do here? *) - fits w ((ind, mode, hd)::rest) - | (_ind, _mode, CustomLayout _)::rest -> - fits w rest - -let toString ~width doc = - let doc = propagateForcedBreaks doc in - let buffer = MiniBuffer.create 1000 in - - let rec process ~pos lineSuffices stack = - match stack with - | ((ind, mode, doc) as cmd)::rest -> - begin match doc with - | Nil | BreakParent -> - process ~pos lineSuffices rest - | Text txt -> - MiniBuffer.add_string buffer txt; - process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> - process ~pos ((ind, mode, doc)::lineSuffices) rest - | Concat docs -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - process ~pos lineSuffices (List.append ops rest) - | Indent doc -> - process ~pos lineSuffices ((ind + 2, mode, doc)::rest) - | IfBreaks {yes = breakDoc; no = flatDoc} -> - if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc)::rest) - else - process ~pos lineSuffices ((ind, mode, flatDoc)::rest) - | LineBreak lineStyle -> - if mode = Break then ( - begin match lineSuffices with - | [] -> - MiniBuffer.flush_newline buffer; - MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); - process ~pos:ind [] rest - | _docs -> - process ~pos:ind [] (List.concat [List.rev lineSuffices; cmd::rest]) - end - ) else (* mode = Flat *) ( - let pos = match lineStyle with - | Classic -> MiniBuffer.add_string buffer " "; pos + 1 - | Hard -> MiniBuffer.flush_newline buffer; 0 - | Soft -> pos - in - process ~pos lineSuffices rest - ) - | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc)::rest)) then - process ~pos lineSuffices ((ind, Break, doc)::rest) - else - process ~pos lineSuffices ((ind, Flat, doc)::rest) - | CustomLayout docs -> - let rec findGroupThatFits groups = match groups with - | [] -> Nil - | [lastGroup] -> lastGroup - | doc::docs -> - if (fits (width - pos) ((ind, Flat, doc)::rest)) then - doc - else - findGroupThatFits docs - in - let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc)::rest) - end - | [] -> - begin match lineSuffices with - | [] -> () - | suffices -> - process ~pos:0 [] (List.rev suffices) - end - in - process ~pos:0 [] [0, Flat, doc]; - - let len = MiniBuffer.length buffer in - if len > 0 && MiniBuffer.unsafe_get buffer (len - 1) != '\n' then - MiniBuffer.add_char buffer '\n'; - MiniBuffer.contents buffer - - -let debug t = - let rec toDoc = function - | Nil -> text "nil" - | BreakParent -> text "breakparent" - | Text txt -> text ("text(" ^ txt ^ ")") - | LineSuffix doc -> group( - concat [ - text "linesuffix("; - indent ( - concat [line; toDoc doc] - ); - line; - text ")" - ] - ) - | Concat docs -> group( - concat [ - text "concat("; - indent ( - concat [ - line; - join ~sep:(concat [text ","; line]) - (List.map toDoc docs) ; - ] - ); - line; - text ")" - ] - ) - | CustomLayout docs -> group( - concat [ - text "customLayout("; - indent ( - concat [ - line; - join ~sep:(concat [text ","; line]) - (List.map toDoc docs) ; - ] - ); - line; - text ")" - ] - ) - | Indent doc -> - concat [ - text "indent("; - softLine; - toDoc doc; - softLine; - text ")"; - ] - | IfBreaks {yes = trueDoc; no = falseDoc} -> - group( - concat [ - text "ifBreaks("; - indent ( - concat [ - line; - toDoc trueDoc; - concat [text ","; line]; - toDoc falseDoc; - ] - ); - line; - text ")" - ] - ) - | LineBreak break -> - let breakTxt = match break with - | Classic -> "Classic" - | Soft -> "Soft" - | Hard -> "Hard" - in - text ("LineBreak(" ^ breakTxt ^ ")") - | Group {shouldBreak; doc} -> - group( - concat [ - text "Group("; - indent ( - concat [ - line; - text ("shouldBreak: " ^ (string_of_bool shouldBreak)); - concat [text ","; line]; - toDoc doc; - ] - ); - line; - text ")" - ] - ) - in - let doc = toDoc t in - toString ~width:10 doc |> print_endline - [@@live] \ No newline at end of file diff --git a/jscomp/napkin/napkin_doc.mli b/jscomp/napkin/napkin_doc.mli deleted file mode 100644 index cf72c85a8d..0000000000 --- a/jscomp/napkin/napkin_doc.mli +++ /dev/null @@ -1,38 +0,0 @@ -type t - -val nil: t -val line: t -val hardLine: t -val softLine: t -val text: string -> t -val concat: t list -> t -val indent: t -> t -val ifBreaks: t -> t -> t -val lineSuffix: t -> t -val group: t -> t -val breakableGroup: forceBreak : bool -> t -> t -val customLayout: t list -> t -val breakParent: t -val join: sep: t -> t list -> t - -val space: t -val comma: t -val dot: t -val dotdot: t -val dotdotdot: t -val lessThan: t -val greaterThan: t -val lbrace: t -val rbrace: t -val lparen: t -val rparen: t -val lbracket: t -val rbracket: t -val question: t -val tilde: t -val equal: t -val trailingComma: t -val doubleQuote: t - -val toString: width: int -> t -> string -val debug: t -> unit [@@live] \ No newline at end of file diff --git a/jscomp/napkin/napkin_driver.ml b/jscomp/napkin/napkin_driver.ml deleted file mode 100644 index 6c2e10437e..0000000000 --- a/jscomp/napkin/napkin_driver.ml +++ /dev/null @@ -1,162 +0,0 @@ -type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Napkin_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 -> string -} - -type printEngine = { - printImplementation: - width: int - -> filename: string - -> comments: Napkin_comment.t list - -> Parsetree.structure - -> unit; - printInterface: - width: int - -> filename: string - -> comments: Napkin_comment.t list - -> Parsetree.signature - -> unit; -} - - - - - - - - -module IO: sig - val readFile: string -> string - val readStdin: unit -> string -end = struct - (* random chunk size: 2^15, TODO: why do we guess randomly? *) - let chunkSize = 32768 - - let readFile filename = - let chan = open_in filename in - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input chan chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr chan; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () - - let readStdin () = - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input stdin chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr stdin; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () -end - -let setup ~filename ~forPrinter () = - let src = if filename = "" then IO.readStdin () else IO.readFile filename in - let mode = if forPrinter then Napkin_parser.Default - else ParseForTypeChecker - in - Napkin_parser.make ~mode src filename - -let parsingEngine = { - parseImplementation = begin fun ~forPrinter ~filename -> - let engine = setup ~filename ~forPrinter () in - let structure = Napkin_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 = Bytes.to_string 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 = Napkin_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 = Bytes.to_string engine.scanner.src; - parsetree = signature; - diagnostics; - invalid; - comments = List.rev engine.comments; - } - end; - stringOfDiagnostics = begin fun ~source ~filename:_ diagnostics -> - let style = Napkin_diagnostics.parseReportStyle "" in - Napkin_diagnostics.stringOfReport ~style diagnostics source - end; -} - -let printEngine = { - printImplementation = begin fun ~width ~filename:_ ~comments structure -> - Napkin_printer.printImplementation - ~width structure comments - end; - printInterface = begin fun ~width ~filename:_ ~comments signature -> - Napkin_printer.printInterface - ~width signature comments - end; -} - -let parse_implementation sourcefile = - Location.input_name := sourcefile; - let parseResult = - parsingEngine.parseImplementation ~forPrinter:false ~filename:sourcefile - in - let () = if parseResult.invalid then - let msg = - let style = Napkin_diagnostics.parseReportStyle "" in - Napkin_diagnostics.stringOfReport ~style parseResult.diagnostics parseResult.source - in - raise (Location.Error (Location.error msg)) - in - parseResult.parsetree - [@@raises Location.Error] - -let parse_interface sourcefile = - Location.input_name := sourcefile; - let parseResult = parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile in - let () = if parseResult.invalid then - let msg = - let style = Napkin_diagnostics.parseReportStyle "" in - Napkin_diagnostics.stringOfReport ~style parseResult.diagnostics parseResult.source - in - raise (Location.Error (Location.error msg)) - in - parseResult.parsetree - [@@raises Location.Error] diff --git a/jscomp/napkin/napkin_driver.mli b/jscomp/napkin/napkin_driver.mli deleted file mode 100644 index e1fbff995a..0000000000 --- a/jscomp/napkin/napkin_driver.mli +++ /dev/null @@ -1,49 +0,0 @@ -type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Napkin_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 -> string -} - -type printEngine = { - printImplementation: - width: int - -> filename: string - -> comments: Napkin_comment.t list - -> Parsetree.structure - -> unit; - printInterface: - width: int - -> filename: string - -> comments: Napkin_comment.t list - -> Parsetree.signature - -> unit; -} - -val parsingEngine: (Napkin_diagnostics.t list) parsingEngine - -val printEngine: printEngine - -(* Napkin implementation parsing compatible with ocaml pparse driver *) -val parse_implementation: - string -> Parsetree.structure -[@@live] -[@@raises Location.Error] - -(* Napkin interface parsing compatible with ocaml pparse driver *) -val parse_interface: - string -> Parsetree.signature -[@@live] -[@@raises Location.Error] diff --git a/jscomp/napkin/napkin_grammar.ml b/jscomp/napkin/napkin_grammar.ml deleted file mode 100644 index 68bc72fb96..0000000000 --- a/jscomp/napkin/napkin_grammar.ml +++ /dev/null @@ -1,366 +0,0 @@ -module Token = Napkin_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 - | 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 - | Primitive - | AtomicTypExpr - | ListExpr - | JsFfiImport - -let toString = function - | OpenDescription -> "an open description" - | ModuleLongIdent -> "a module identifier" - | 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" - | Primitive -> "an external primitive" - | AtomicTypExpr -> "a type" - | ListExpr -> "an ocaml list expr" - | PackageConstraint -> "a package constraint" - | JsFfiImport -> "js ffi import" - | JsxChild -> "jsx child" - -let isSignatureItemStart = function - | Token.At - | Let - | Typ - | External - | Exception - | Open - | Include - | Module - | AtAt - | Export - | PercentPercent -> true - | _ -> false - -let isAtomicPatternStart = function - | Token.Int _ | String _ | Character _ - | 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 _ | 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 _ | At -> 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 - | Primitive -> begin match token with Token.String _ -> true | _ -> false end - | JsxAttribute -> isJsxAttributeStart token - | JsFfiImport -> isJsFfiImportStart token - | _ -> 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 - | Primitive, Semicolon -> true - | Primitive, token when isStructureItemStart token -> true - - | _ -> false - -let isPartOfList grammar token = - isListElement grammar token || isListTerminator grammar token diff --git a/jscomp/napkin/napkin_js_ffi.ml b/jscomp/napkin/napkin_js_ffi.ml deleted file mode 100644 index a2716111d7..0000000000 --- a/jscomp/napkin/napkin_js_ffi.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* 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 "bs.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 "bs.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 \ No newline at end of file diff --git a/jscomp/napkin/napkin_main.ml b/jscomp/napkin/napkin_main.ml deleted file mode 100644 index dc4acf7b04..0000000000 --- a/jscomp/napkin/napkin_main.ml +++ /dev/null @@ -1,135 +0,0 @@ -(* command line flags *) -module NapkinClflags: sig - val recover: bool ref - val print: string ref - val width: int ref - val origin: string ref - val files: string list ref - val interface: bool ref - val report: string ref - - val parse: unit -> unit -end = struct - let recover = ref false - let width = ref 100 - - let files = ref [] - let addFilename filename = files := filename::(!files) - - let print = ref "" - let origin = ref "" - let interface = ref false - let report = ref "pretty" - - let usage = "Usage: napkinscript \nOptions are:" - - let spec = [ - ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); - ("-print", Arg.String (fun txt -> print := txt), "Print either binary or napkinscript"); - ("-parse", Arg.String (fun txt -> origin := txt), "Parse reasonBinary or napkinscript"); - ("-width", Arg.Int (fun w -> width := w), "Specify the line length that the printer will wrap on" ); - ("-interface", Arg.Unit (fun () -> interface := true), "Parse as interface"); - (* ("-report", Arg.String (fun txt -> report := txt), "Stylize errors and messages using color and context. Accepts `Pretty` and `Plain`. Default `Plain`") *) - ] - - let parse () = Arg.parse spec addFilename usage -end - -module CliArgProcessor = struct - type backend = Parser: ('diagnostics) Napkin_driver.parsingEngine -> backend [@@unboxed] - - let processFile ~isInterface ~width ~recover ~origin ~target ~report:_ filename = - try - 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 Napkin_reason_binary_driver.parsingEngine - | "ml" | "ocaml" -> Parser Napkin_ml_parser_driver.parsingEngine - | _ -> Parser Napkin_driver.parsingEngine - in - let printEngine = - match target with - | "ns" | "napkinscript" -> Napkin_driver.printEngine - | "ml" | "ocaml" -> Napkin_ml_parser_driver.printEngine - | "ast" -> Napkin_ast_debugger.printEngine - | "sexp" -> Napkin_ast_debugger.sexpPrintEngine - | _ -> Napkin_binary_driver.printEngine - in - - let forPrinter = match target with - | "ns" | "napkinscript" | "sexp" -> true - | _ -> false - in - - let Parser backend = parsingEngine in - if processInterface then - let parseResult = backend.parseInterface ~forPrinter ~filename in - if parseResult.invalid then - let () = prerr_string ( - backend.stringOfDiagnostics - ~source:parseResult.source - ~filename:parseResult.filename - parseResult.diagnostics) - in - if recover || not parseResult.invalid then - printEngine.printInterface - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - else - () - else - printEngine.printInterface - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - else - let parseResult = backend.parseImplementation ~forPrinter ~filename in - if parseResult.invalid then - let () = prerr_string ( - backend.stringOfDiagnostics - ~source:parseResult.source - ~filename:parseResult.filename - parseResult.diagnostics) - in - if recover || not parseResult.invalid then - printEngine.printImplementation - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - else - () - else - printEngine.printImplementation - ~width ~filename ~comments:parseResult.comments parseResult.parsetree - with - | Failure txt -> - prerr_string txt; - prerr_newline(); - exit 1 - | _ -> exit 1 -end - -let () = - if not !Sys.interactive then begin - NapkinClflags.parse (); - match !NapkinClflags.files with - | [] -> (* stdin *) - CliArgProcessor.processFile - ~isInterface:!NapkinClflags.interface - ~width:!NapkinClflags.width - ~recover:!NapkinClflags.recover - ~target:!NapkinClflags.print - ~origin:!NapkinClflags.origin - ~report:!NapkinClflags.report - "" - | files -> - List.iter (fun filename -> - CliArgProcessor.processFile - ~isInterface:!NapkinClflags.interface - ~width:!NapkinClflags.width - ~recover:!NapkinClflags.recover - ~target:!NapkinClflags.print - ~origin:!NapkinClflags.origin - ~report:!NapkinClflags.report - filename - ) files - - end \ No newline at end of file diff --git a/jscomp/napkin/napkin_minibuffer.ml b/jscomp/napkin/napkin_minibuffer.ml deleted file mode 100644 index c72b5f8911..0000000000 --- a/jscomp/napkin/napkin_minibuffer.ml +++ /dev/null @@ -1,55 +0,0 @@ -type t = { - mutable buffer : bytes; - mutable position : int; - mutable length : int; -} - -let create n = - let n = if n < 1 then 1 else n in - let s = (Bytes.create [@doesNotRaise]) n in - {buffer = s; position = 0; length = n} - -let contents b = Bytes.sub_string b.buffer 0 b.position - -let unsafe_get b ofs = - Bytes.unsafe_get b.buffer ofs - -let length b = b.position - -(* Can't be called directly, don't add to the interface *) -let resize_internal b more = - let len = b.length in - let new_len = ref len in - while b.position + more > !new_len do new_len := 2 * !new_len done; - if !new_len > Sys.max_string_length then begin - if b.position + more <= Sys.max_string_length - then new_len := Sys.max_string_length - end; - let new_buffer = (Bytes.create [@doesNotRaise]) !new_len in - (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in - this tricky function that is slow anyway. *) - Bytes.blit b.buffer 0 new_buffer 0 b.position [@doesNotRaise]; - b.buffer <- new_buffer; - b.length <- !new_len - -let add_char b c = - let pos = b.position in - if pos >= b.length then resize_internal b 1; - Bytes.unsafe_set b.buffer pos c; - b.position <- pos + 1 - -let add_string b s = - let len = String.length s in - let new_position = b.position + len in - if new_position > b.length then resize_internal b len; - Bytes.blit_string s 0 b.buffer b.position len [@doesNotRaise]; - b.position <- new_position - -(* adds newline and trims all preceding whitespace *) -let flush_newline b = - let position = ref (b.position) in - while (Bytes.unsafe_get b.buffer (!position - 1)) = ' ' && !position >= 0 do - position := !position - 1; - done; - b.position <- !position; - add_char b '\n' \ No newline at end of file diff --git a/jscomp/napkin/napkin_minibuffer.mli b/jscomp/napkin/napkin_minibuffer.mli deleted file mode 100644 index 4c8e459ffe..0000000000 --- a/jscomp/napkin/napkin_minibuffer.mli +++ /dev/null @@ -1,8 +0,0 @@ -type t -val add_char : t -> char -> unit -val add_string : t -> string -> unit -val contents : t -> string -val create : int -> t -val flush_newline : t -> unit -val length : t -> int -val unsafe_get : t -> int -> char \ No newline at end of file diff --git a/jscomp/napkin/napkin_ml_parser_driver.ml b/jscomp/napkin/napkin_ml_parser_driver.ml deleted file mode 100644 index 1ca5d48380..0000000000 --- a/jscomp/napkin/napkin_ml_parser_driver.ml +++ /dev/null @@ -1,130 +0,0 @@ -module OcamlParser = Parser - -module IO: sig - val readFile: string -> string - val readStdin: unit -> string -end = struct - (* random chunk size: 2^15, TODO: why do we guess randomly? *) - let chunkSize = 32768 - - let readFile filename = - let chan = open_in filename in - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input chan chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr chan; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () - - let readStdin () = - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input stdin chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr stdin; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () -end - -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 = Napkin_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 = { - Napkin_driver.parseImplementation = begin fun ~forPrinter:_ ~filename -> - let lexbuf = setup ~filename in - let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in - let structure = - Parse.implementation lexbuf - |> Napkin_ast_conversion.replaceStringLiteralStructure stringData - |> Napkin_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 - |> Napkin_ast_conversion.replaceStringLiteralSignature stringData - |> Napkin_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 = Napkin_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/jscomp/napkin/napkin_ml_parser_driver.mli b/jscomp/napkin/napkin_ml_parser_driver.mli deleted file mode 100644 index d9d793fc23..0000000000 --- a/jscomp/napkin/napkin_ml_parser_driver.mli +++ /dev/null @@ -1,14 +0,0 @@ - -module IO : sig - val readFile : string -> string [@@live] - val readStdin : unit -> string [@@live] -end - -val setup : filename:string -> Lexing.lexbuf [@@live] - -val extractOcamlConcreteSyntax : - string -> (string * Location.t) list * Napkin_comment.t list [@@live] - -val parsingEngine : unit Napkin_driver.parsingEngine - -val printEngine : Napkin_driver.printEngine diff --git a/jscomp/napkin/napkin_outcome_printer.ml b/jscomp/napkin/napkin_outcome_printer.ml deleted file mode 100644 index 58579f7fe1..0000000000 --- a/jscomp/napkin/napkin_outcome_printer.ml +++ /dev/null @@ -1,978 +0,0 @@ - module Doc = Napkin_doc - (* Napkin doesn't have parenthesized identifiers. - * We don't support custom operators. *) - let parenthesized_ident _name = true - - (* TODO: better allocation strategy for the buffer *) - let escapeStringContents s = - let len = String.length s in - let b = Buffer.create len in - for i = 0 to len - 1 do - let c = (String.get [@doesNotRaise]) s i in - if c = '\008' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'b'; - ) else if c = '\009' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 't'; - ) else if c = '\010' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'n'; - ) else if c = '\013' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'r'; - ) else if c = '\034' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '"'; - ) else if c = '\092' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\'; - ) else ( - Buffer.add_char b c; - ); - done; - Buffer.contents b - - (* let rec print_ident fmt ident = match ident with - | Outcometree.Oide_ident s -> Format.pp_print_string fmt s - | Oide_dot (id, s) -> - print_ident fmt id; - Format.pp_print_char fmt '.'; - Format.pp_print_string fmt s - | Oide_apply (id1, id2) -> - print_ident fmt id1; - Format.pp_print_char fmt '('; - print_ident fmt id2; - Format.pp_print_char fmt ')' *) - - let rec printOutIdentDoc (ident : Outcometree.out_ident) = - match ident with - | Oide_ident s -> Doc.text s - | Oide_dot (ident, s) -> Doc.concat [ - printOutIdentDoc ident; - Doc.dot; - Doc.text s; - ] - | Oide_apply (call, arg) ->Doc.concat [ - printOutIdentDoc call; - Doc.lparen; - printOutIdentDoc arg; - Doc.rparen; - ] - - let printOutAttributeDoc (outAttribute: Outcometree.out_attribute) = - Doc.concat [ - Doc.text "@"; - Doc.text outAttribute.oattr_name; - ] - - let printOutAttributesDoc (attrs: Outcometree.out_attribute list) = - match attrs with - | [] -> Doc.nil - | attrs -> - Doc.concat [ - Doc.group ( - Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs) - ); - Doc.line; - ] - - let rec collectArrowArgs (outType: Outcometree.out_type) args = - match outType with - | Otyp_arrow (label, argType, returnType) -> - let arg = (label, argType) in - collectArrowArgs returnType (arg::args) - | _ as returnType -> - (List.rev args, returnType) - - let rec collectFunctorArgs (outModuleType: Outcometree.out_module_type) args = - match outModuleType with - | Omty_functor (lbl, optModType, returnModType) -> - let arg = (lbl, optModType) in - collectFunctorArgs returnModType (arg::args) - | _ -> - (List.rev args, outModuleType) - - let rec printOutTypeDoc (outType: Outcometree.out_type) = - match outType with - | Otyp_abstract | Otyp_variant _ (* don't support poly-variants atm *) | Otyp_open -> Doc.nil - | Otyp_alias (typ, aliasTxt) -> - Doc.concat [ - printOutTypeDoc typ; - Doc.text " as '"; - Doc.text aliasTxt - ] - | Otyp_constr (outIdent, []) -> - printOutIdentDoc outIdent - | Otyp_manifest (typ1, typ2) -> - Doc.concat [ - printOutTypeDoc typ1; - Doc.text " = "; - printOutTypeDoc typ2; - ] - | Otyp_record record -> - printRecordDeclarationDoc ~inline:true record - | Otyp_stuff txt -> Doc.text txt - | Otyp_var (ng, s) -> Doc.concat [ - Doc.text ("'" ^ (if ng then "_" else "")); - Doc.text s - ] - | Otyp_object (fields, rest) -> printObjectFields fields rest - | Otyp_class _ -> Doc.nil - | Otyp_attribute (typ, attribute) -> - Doc.group ( - Doc.concat [ - printOutAttributeDoc attribute; - Doc.line; - printOutTypeDoc typ; - ] - ) - (* example: Red | Blue | Green | CustomColour(float, float, float) *) - | Otyp_sum constructors -> - printOutConstructorsDoc constructors - - (* example: {"name": string, "age": int} *) - | Otyp_constr ( - (Oide_dot ((Oide_ident "Js"), "t")), - [Otyp_object (fields, rest)] - ) -> printObjectFields fields rest - - (* example: node *) - | Otyp_constr (outIdent, args) -> - let argsDoc = match args with - | [] -> Doc.nil - | args -> - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - in - Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - argsDoc; - ] - ) - | Otyp_tuple tupleArgs -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc tupleArgs - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - | Otyp_poly (vars, outType) -> - Doc.group ( - Doc.concat [ - Doc.join ~sep:Doc.space ( - List.map (fun var -> Doc.text ("'" ^ var)) vars - ); - printOutTypeDoc outType; - ] - ) - | Otyp_arrow _ as typ -> - let (typArgs, typ) = collectArrowArgs typ [] in - let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, typ) -> - if lbl = "" then - printOutTypeDoc typ - else - Doc.group ( - Doc.concat [ - Doc.text ("~" ^ lbl ^ ": "); - printOutTypeDoc typ - ] - ) - ) typArgs - ) in - let argsDoc = - let needsParens = match typArgs with - | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true - (* single argument should not be wrapped *) - | ["", _] -> false - | _ -> true - in - if needsParens then - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - args; - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - else args - in - Doc.concat [ - argsDoc; - Doc.text " => "; - printOutTypeDoc typ; - ] - | Otyp_module (_modName, _stringList, _outTypes) -> - Doc.nil - - and printObjectFields fields rest = - let dots = match rest with - | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") - | None -> Doc.nil - in - Doc.group ( - Doc.concat [ - Doc.lbrace; - dots; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, outType) -> Doc.group ( - Doc.concat [ - Doc.text ("\"" ^ lbl ^ "\": "); - printOutTypeDoc outType; - ] - )) fields - ) - ] - ); - Doc.softLine; - Doc.trailingComma; - Doc.rbrace; - ] - ) - - - and printOutConstructorsDoc constructors = - Doc.group ( - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line ( - List.mapi (fun i constructor -> - Doc.concat [ - if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil; - printOutConstructorDoc constructor; - ] - ) constructors - ) - ] - ) - ) - - and printOutConstructorDoc (name, args, gadt) = - let gadtDoc = match gadt with - | Some outType -> - Doc.concat [ - Doc.text ": "; - printOutTypeDoc outType - ] - | None -> Doc.nil - in - let argsDoc = match args with - | [] -> Doc.nil - | [Otyp_record record] -> - (* inline records - * | Root({ - * mutable value: 'value, - * mutable updatedTime: float, - * }) - *) - Doc.concat [ - Doc.lparen; - Doc.indent ( - printRecordDeclarationDoc ~inline:true record; - ); - Doc.rparen; - ] - | _types -> - Doc.indent ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - Doc.text name; - argsDoc; - gadtDoc - ] - ) - - and printRecordDeclRowDoc (name, mut, arg) = - Doc.group ( - Doc.concat [ - if mut then Doc.text "mutable " else Doc.nil; - Doc.text name; - Doc.text ": "; - printOutTypeDoc arg; - ] - ) - - and printRecordDeclarationDoc ~inline rows = - let content = Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printRecordDeclRowDoc rows - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] in - if not inline then - Doc.group content - else content - - let printOutType fmt outType = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeDoc outType)) - - let printTypeParameterDoc (typ, (co, cn)) = - Doc.concat [ - if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil; - if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ) - ] - - - let rec printOutSigItemDoc (outSigItem : Outcometree.out_sig_item) = - match outSigItem with - | Osig_class _ | Osig_class_type _ -> Doc.nil - | Osig_ellipsis -> Doc.dotdotdot - | Osig_value valueDecl -> - Doc.group ( - Doc.concat [ - printOutAttributesDoc valueDecl.oval_attributes; - Doc.text ( - match valueDecl.oval_prims with | [] -> "let " | _ -> "external " - ); - Doc.text valueDecl.oval_name; - Doc.text ":"; - Doc.space; - printOutTypeDoc valueDecl.oval_type; - match valueDecl.oval_prims with - | [] -> Doc.nil - | primitives -> Doc.indent ( - Doc.concat [ - Doc.text " ="; - Doc.line; - Doc.group ( - Doc.join ~sep:Doc.line (List.map (fun prim -> Doc.text ("\"" ^ prim ^ "\"")) primitives) - ) - ] - ) - ] - ) - | Osig_typext (outExtensionConstructor, _outExtStatus) -> - printOutExtensionConstructorDoc outExtensionConstructor - | Osig_modtype (modName, Omty_signature []) -> - Doc.concat [ - Doc.text "module type "; - Doc.text modName; - ] - | Osig_modtype (modName, outModuleType) -> - Doc.group ( - Doc.concat [ - Doc.text "module type "; - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModuleType; - ] - ) - | Osig_module (modName, Omty_alias ident, _) -> - Doc.group ( - Doc.concat [ - Doc.text "module "; - Doc.text modName; - Doc.text " ="; - Doc.line; - printOutIdentDoc ident; - ] - ) - | Osig_module (modName, outModType, outRecStatus) -> - Doc.group ( - Doc.concat [ - Doc.text ( - match outRecStatus with - | Orec_not -> "module " - | Orec_first -> "module rec " - | Orec_next -> "and" - ); - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModType; - ] - ) - | Osig_type (outTypeDecl, outRecStatus) -> - (* TODO: manifest ? *) - let attrs = match outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed with - | false, false -> Doc.nil - | true, false -> - Doc.concat [Doc.text "@immediate"; Doc.line] - | false, true -> - Doc.concat [Doc.text "@unboxed"; Doc.line] - | true, true -> - Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] - in - let kw = Doc.text ( - match outRecStatus with - | Orec_not -> "type " - | Orec_first -> "type rec " - | Orec_next -> "and " - ) in - let typeParams = match outTypeDecl.otype_params with - | [] -> Doc.nil - | _params -> Doc.group ( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypeParameterDoc outTypeDecl.otype_params - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - ) - in - let privateDoc = match outTypeDecl.otype_private with - | Asttypes.Private -> Doc.text "private " - | Public -> Doc.nil - in - let kind = match outTypeDecl.otype_type with - | Otyp_open -> Doc.concat [ - Doc.text " = "; - privateDoc; - Doc.text ".."; - ] - | Otyp_abstract -> Doc.nil - | Otyp_record record -> Doc.concat [ - Doc.text " = "; - privateDoc; - printRecordDeclarationDoc ~inline:false record; - ] - | typ -> Doc.concat [ - Doc.text " = "; - printOutTypeDoc typ - ] - in - let constraints = match outTypeDecl.otype_cstrs with - | [] -> Doc.nil - | _ -> Doc.group ( - Doc.concat [ - Doc.line; - Doc.indent ( - Doc.concat [ - Doc.hardLine; - Doc.join ~sep:Doc.line (List.map (fun (typ1, typ2) -> - Doc.group ( - Doc.concat [ - Doc.text "constraint "; - printOutTypeDoc typ1; - Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutTypeDoc typ2; - ] - ) - ] - ) - ) outTypeDecl.otype_cstrs) - ] - ) - ] - ) in - Doc.group ( - Doc.concat [ - attrs; - Doc.group ( - Doc.concat [ - attrs; - kw; - Doc.text outTypeDecl.otype_name; - typeParams; - kind - ] - ); - constraints - ] - ) - - and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = - match outModType with - | Omty_abstract -> Doc.nil - | Omty_ident ident -> printOutIdentDoc ident - (* example: module Increment = (M: X_int) => X_int *) - | Omty_functor _ -> - let (args, returnModType) = collectFunctorArgs outModType [] in - let argsDoc = match args with - | [_, None] -> Doc.text "()" - | args -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, optModType) -> Doc.group ( - Doc.concat [ - Doc.text lbl; - match optModType with - | None -> Doc.nil - | Some modType -> Doc.concat [ - Doc.text ": "; - printOutModuleTypeDoc modType; - ] - ] - )) args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - argsDoc; - Doc.text " => "; - printOutModuleTypeDoc returnModType - ] - ) - | Omty_signature [] -> Doc.nil - | Omty_signature signature -> - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutSignatureDoc signature; - ] - ); - Doc.softLine; - Doc.rbrace; - ] - ) - | Omty_alias _ident -> Doc.nil - - and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | Outcometree.Osig_typext(ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - Outcometree.Osig_typext(ext, Oext_next) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - items - in - let te = - { Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - let doc = printOutTypeExtensionDoc te in - loop items (doc::acc) - | item::items -> - let doc = printOutSigItemDoc item in - loop items (doc::acc) - in - match loop signature [] with - | [doc] -> doc - | docs -> - Doc.breakableGroup ~forceBreak:true ( - Doc.join ~sep:Doc.line docs - ) - - and printOutExtensionConstructorDoc (outExt : Outcometree.out_extension_constructor) = - let typeParams = match outExt.oext_type_params with - | [] -> Doc.nil - | params -> - Doc.group( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) - params - - ) - ] - ); - Doc.softLine; - Doc.greaterThan; - ] - ) - - in - Doc.group ( - Doc.concat [ - Doc.text "type "; - Doc.text outExt.oext_type_name; - typeParams; - Doc.text " +="; - Doc.line; - if outExt.oext_private = Asttypes.Private then - Doc.text "private " - else - Doc.nil; - printOutConstructorDoc - (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type) - ] - ) - - and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = - let typeParams = match typeExtension.otyext_params with - | [] -> Doc.nil - | params -> - Doc.group( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) - params - - ) - ] - ); - Doc.softLine; - Doc.greaterThan; - ] - ) - - in - Doc.group ( - Doc.concat [ - Doc.text "type "; - Doc.text typeExtension.otyext_name; - typeParams; - Doc.text " +="; - if typeExtension.otyext_private = Asttypes.Private then - Doc.text "private " - else - Doc.nil; - printOutConstructorsDoc typeExtension.otyext_constructors; - ] - ) - - let printOutSigItem fmt outSigItem = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSigItemDoc outSigItem)) - - let printOutSignature fmt signature = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSignatureDoc signature)) - - let validFloatLexeme s = - let l = String.length s in - let rec loop i = - if i >= l then s ^ "." else - match (s.[i] [@doesNotRaise]) with - | '0' .. '9' | '-' -> loop (i+1) - | _ -> s - in loop 0 - - let floatRepres f = - match classify_float f with - | FP_nan -> "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = (float_of_string [@doesNotRaise]) s1 then s1 else - let s2 = Printf.sprintf "%.15g" f in - if f = (float_of_string [@doesNotRaise]) s2 then s2 else - Printf.sprintf "%.18g" f - in validFloatLexeme float_val - - let rec printOutValueDoc (outValue : Outcometree.out_value) = - match outValue with - | Oval_array outValues -> - Doc.group ( - Doc.concat [ - Doc.lbracket; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ] - ) - | Oval_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") - | Oval_constr (outIdent, outValues) -> - Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - | Oval_ellipsis -> Doc.text "..." - | Oval_int i -> Doc.text (Format.sprintf "%i" i) - | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) - | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) - | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) - | Oval_float f -> Doc.text (floatRepres f) - | Oval_list outValues -> - Doc.group ( - Doc.concat [ - Doc.text "list["; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ] - ) - | Oval_printer fn -> - let fmt = Format.str_formatter in - fn fmt; - let str = Format.flush_str_formatter () in - Doc.text str - | Oval_record rows -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (outIdent, outValue) -> Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - Doc.text ": "; - printOutValueDoc outValue; - ] - ) - ) rows - ); - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escapeStringContents txt) - | Oval_stuff txt -> Doc.text txt - | Oval_tuple outValues -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - (* Not supported by NapkinScript *) - | Oval_variant _ -> Doc.nil - - let printOutExceptionDoc exc outValue = - match exc with - | Sys.Break -> Doc.text "Interrupted." - | Out_of_memory -> Doc.text "Out of memory during evaluation." - | Stack_overflow -> - Doc.text "Stack overflow during evaluation (looping recursion?)." - | _ -> - Doc.group ( - Doc.indent( - Doc.concat [ - Doc.text "Exception:"; - Doc.line; - printOutValueDoc outValue; - ] - ) - ) - - let printOutPhraseSignature signature = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | (Outcometree.Osig_typext(ext, Oext_first), None)::signature -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Outcometree.Osig_typext(ext, Oext_next), None)::items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type)::acc) - items - | _ -> (List.rev acc, items) - in - let exts, signature = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - signature - in - let te = - { Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - let doc = printOutTypeExtensionDoc te in - loop signature (doc::acc) - | (sigItem, optOutValue)::signature -> - let doc = match optOutValue with - | None -> - printOutSigItemDoc sigItem - | Some outValue -> - Doc.group ( - Doc.concat [ - printOutSigItemDoc sigItem; - Doc.text " = "; - printOutValueDoc outValue; - ] - ) - in - loop signature (doc::acc) - in - Doc.breakableGroup ~forceBreak:true ( - Doc.join ~sep:Doc.line (loop signature []) - ) - - let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = - match outPhrase with - | Ophr_eval (outValue, outType) -> - Doc.group ( - Doc.concat [ - Doc.text "- : "; - printOutTypeDoc outType; - Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutValueDoc outValue; - ] - ) - ] - ) - | Ophr_signature [] -> Doc.nil - | Ophr_signature signature -> printOutPhraseSignature signature - | Ophr_exception (exc, outValue) -> - printOutExceptionDoc exc outValue - - let printOutPhrase fmt outPhrase = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutPhraseDoc outPhrase)) - - let printOutModuleType fmt outModuleType = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType)) - - let printOutTypeExtension fmt typeExtension = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension)) - - let printOutValue fmt outValue = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutValueDoc outValue)) - - - - - -(* Not supported in Napkin *) -(* Oprint.out_class_type *) - let setup = lazy begin - Oprint.out_value := printOutValue; - Oprint.out_type := printOutType; - Oprint.out_module_type := printOutModuleType; - Oprint.out_sig_item := printOutSigItem; - Oprint.out_signature := printOutSignature; - Oprint.out_type_extension := printOutTypeExtension; - Oprint.out_phrase := printOutPhrase - end - \ No newline at end of file diff --git a/jscomp/napkin/napkin_outcome_printer.mli b/jscomp/napkin/napkin_outcome_printer.mli deleted file mode 100644 index ae6776c7bb..0000000000 --- a/jscomp/napkin/napkin_outcome_printer.mli +++ /dev/null @@ -1,5 +0,0 @@ - - -val parenthesized_ident : string -> bool [@@live] - -val setup : unit lazy_t [@@live] \ No newline at end of file diff --git a/jscomp/napkin/napkin_parens.ml b/jscomp/napkin/napkin_parens.ml deleted file mode 100644 index 83c0bba758..0000000000 --- a/jscomp/napkin/napkin_parens.ml +++ /dev/null @@ -1,404 +0,0 @@ -module ParsetreeViewer = Napkin_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}}, - [_, _left; _, _right] - ) when ParsetreeViewer.isBinaryOperator 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}}, - [_, _left; _, _right] - ) when ParsetreeViewer.isBinaryOperator 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 _} -> 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 \ No newline at end of file diff --git a/jscomp/napkin/napkin_parens.mli b/jscomp/napkin/napkin_parens.mli deleted file mode 100644 index ec6c41bbd6..0000000000 --- a/jscomp/napkin/napkin_parens.mli +++ /dev/null @@ -1,32 +0,0 @@ -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 \ No newline at end of file diff --git a/jscomp/napkin/napkin_parser.ml b/jscomp/napkin/napkin_parser.ml deleted file mode 100644 index af385b6d4e..0000000000 --- a/jscomp/napkin/napkin_parser.ml +++ /dev/null @@ -1,159 +0,0 @@ -module Scanner = Napkin_scanner -module Diagnostics = Napkin_diagnostics -module Token = Napkin_token -module Grammar = Napkin_grammar -module Reporting = Napkin_reporting - -module Comment = Napkin_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 = - let d = Diagnostics.make - ~filename:p.scanner.filename - ~startPos:(match startPos with | Some pos -> pos | None -> p.startPos) - ~endPos:(match endPos with | Some pos -> pos | None -> p.endPos) - error - in - try - if (!(List.hd p.regions) = Report) then ( - p.diagnostics <- d::p.diagnostics; - List.hd p.regions := Silent - ) - with Failure _ -> () - - let beginRegion p = - p.regions <- ref Report :: p.regions - let endRegion p = - try p.regions <- List.tl p.regions with Failure _ -> () - - (* 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 checkProgress ~prevEndPos ~result p = - if p.endPos == prevEndPos - then None - else Some result - - let make ?(mode=ParseForTypeChecker) src filename = - let scanner = Scanner.make (Bytes.of_string src) filename 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 - ~filename - ~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 rdOffset = p.scanner.rdOffset 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.rdOffset <- rdOffset; - 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/jscomp/napkin/napkin_parser.mli b/jscomp/napkin/napkin_parser.mli deleted file mode 100644 index 06fb367633..0000000000 --- a/jscomp/napkin/napkin_parser.mli +++ /dev/null @@ -1,46 +0,0 @@ -module Scanner = Napkin_scanner -module Token = Napkin_token -module Grammar = Napkin_grammar -module Reporting = Napkin_reporting -module Diagnostics = Napkin_diagnostics -module Comment = Napkin_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 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 \ No newline at end of file diff --git a/jscomp/napkin/napkin_parsetree_viewer.ml b/jscomp/napkin/napkin_parsetree_viewer.ml deleted file mode 100644 index 216f8d1d19..0000000000 --- a/jscomp/napkin/napkin_parsetree_viewer.ml +++ /dev/null @@ -1,571 +0,0 @@ -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 isHuggableExpression expr = - match expr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj"}, _) - | Pexp_record _ -> true - | _ when isBlockExpr expr -> true - | _ when isBracedExpr expr -> true - | _ -> false - -let isHuggableRhs expr = - match expr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj"}, _) - | Pexp_record _ -> true - | _ when isBracedExpr expr -> true - | _ -> false - -let isHuggablePattern pattern = - match pattern.ppat_desc with - | Ppat_array _ - | Ppat_tuple _ - | Ppat_record _ - | 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 - -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}}, - [(Nolabel, _operand1); (Nolabel, _operand2)] - ) when isBinaryOperator operator -> 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 = match attributes with - | ({Location.txt = "JSX"},_)::_ -> true - | _ -> false - -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"}, _) -> false - | _ -> true - ) attrs - -let partitionPrinteableAttributes attrs = - List.partition (fun attr -> match attr with - | ({Location.txt="bs" | "ns.ternary" | "ns.iflet"}, _) -> 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 splitGenTypeAttr attrs = - match attrs with - | ({Location.txt = "genType"}, PStr [])::attrs -> (true, attrs) - | attrs -> (false, attrs) - -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 - -let rec isTemplateLiteral expr = - let isPexpConstantString expr = match expr.pexp_desc with - | Pexp_constant (Pconst_string (_, Some _)) -> true - | _ -> false - in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [Nolabel, arg1; Nolabel, arg2] - ) when not (isPexpConstantString arg1 && isPexpConstantString arg2) -> - isTemplateLiteral arg1 || isTemplateLiteral arg2 - | Pexp_constant (Pconst_string (_, Some _)) -> 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 isPipeExpr expr = match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, - [(Nolabel, _operand1); (Nolabel, _operand2)] - ) -> true - | _ -> false - -let extractValueDescriptionFromModExpr modExpr = - let rec loop structure acc = - match structure with - | [] -> List.rev acc - | structureItem::structure -> - begin match structureItem.Parsetree.pstr_desc with - | Pstr_primitive vd -> loop structure (vd::acc) - | _ -> loop structure acc - end - in - match modExpr.pmod_desc with - | Pmod_structure structure -> loop structure [] - | _ -> [] - -type jsImportScope = - | JsGlobalImport (* nothing *) - | JsModuleImport of string (* from "path" *) - | JsScopedImport of string list (* window.location *) - -let classifyJsImport valueDescription = - let rec loop attrs = - let open Parsetree in - match attrs with - | [] -> JsGlobalImport - | ({Location.txt = "bs.scope"}, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _)}])::_ -> - JsScopedImport [s] - | ({Location.txt = "genType.import"}, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _)}])::_ -> - JsModuleImport s - | ({Location.txt = "bs.scope"}, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_tuple exprs}, _)}])::_ -> - let scopes = List.fold_left (fun acc curr -> - match curr.Parsetree.pexp_desc with - | Pexp_constant (Pconst_string (s, _)) -> s::acc - | _ -> acc - ) [] exprs - in - JsScopedImport (List.rev scopes) - | _::attrs -> - loop attrs - in - loop valueDescription.pval_attributes - -let isUnderscoreApplySugar expr = - match expr.pexp_desc with - | Pexp_fun ( - Nolabel, - None, - {ppat_desc = Ppat_var {txt="__x"}}, - {pexp_desc = Pexp_apply _} - ) -> true - | _ -> false diff --git a/jscomp/napkin/napkin_parsetree_viewer.mli b/jscomp/napkin/napkin_parsetree_viewer.mli deleted file mode 100644 index 2be36175ef..0000000000 --- a/jscomp/napkin/napkin_parsetree_viewer.mli +++ /dev/null @@ -1,141 +0,0 @@ -(* 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 splitGenTypeAttr : Parsetree.attributes -> (bool * Parsetree.attributes) - -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 isPipeExpr : Parsetree.expression -> bool - -val extractValueDescriptionFromModExpr: Parsetree.module_expr -> Parsetree.value_description list - -type jsImportScope = - | JsGlobalImport (* nothing *) - | JsModuleImport of string (* from "path" *) - | JsScopedImport of string list (* window.location *) - -val classifyJsImport: Parsetree.value_description -> jsImportScope - -(* (__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 diff --git a/jscomp/napkin/napkin_printer.ml b/jscomp/napkin/napkin_printer.ml deleted file mode 100644 index 0962a9b829..0000000000 --- a/jscomp/napkin/napkin_printer.ml +++ /dev/null @@ -1,4952 +0,0 @@ -module Doc = Napkin_doc -module CommentTable = Napkin_comments_table -module Comment = Napkin_comment -module Token = Napkin_token -module Parens = Napkin_parens -module ParsetreeViewer = Napkin_parsetree_viewer - -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; - Doc.rbrace; - ] - ) - -let getFirstLeadingComment tbl loc = - match Hashtbl.find tbl.CommentTable.leading loc with - | comment::_ -> Some comment - | [] -> None - | exception Not_found -> None - -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 String.length line > 0 then Doc.space else Doc.nil in - List.rev (trailingSpace::doc::acc) |> Doc.concat - | line::lines -> - let line = String.trim line in - let len = String.length line in - if len > 0 && (String.get [@doesNotRaise]) line 0 == '*' then - let doc = Doc.text (" " ^ (String.trim 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 "/*"; - if String.length firstLine > 0 && not (String.equal firstLine "*") then - Doc.space else Doc.nil; - indentStars rest [Doc.hardLine; Doc.text firstLine]; - Doc.text "*/"; - ] - -let printTrailingComment (nodeLoc : Location.t) comment = - let singleLine = Comment.isSingleLineComment comment in - let content = - let txt = Comment.txt comment in - if singleLine then - Doc.text ("// " ^ String.trim txt) - else - printMultilineCommentContent txt - in - let diff = - let cmtStart = (Comment.loc comment).loc_start in - let prevTokEndPos = Comment.prevTokEndPos comment in - cmtStart.pos_lnum - prevTokEndPos.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 ("// " ^ String.trim 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 acc comments = - match comments with - | [] -> Doc.concat (List.rev acc) - | comment::comments -> - let cmtDoc = printTrailingComment loc comment in - loop (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 [] 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 = - let len = String.length txt in - let rec go i = - if i == len then NormalIdent - else - let c = String.unsafe_get txt i in - if i == 0 && not ( - (allowUident && (c >= 'A' && c <= 'Z')) || - (c >= 'a' && c <= 'z') || c = '_' || (c >= '0' && c <= '9')) then - ExoticIdent - else if not ( - (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || c = '\'' - || c = '_' - || (c >= '0' && c <= '9')) - then - ExoticIdent - else - go (i + 1) - in - if Token.isKeywordTxt txt then - ExoticIdent - else - go 0 - -let printIdentLike ?allowUident txt = - match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [ - Doc.text "\\\""; - Doc.text txt; - Doc.text"\"" - ] - | NormalIdent -> Doc.text txt - -let 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 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.text ("\"" ^ txt ^ "\"") - | Pconst_string (txt, Some prefix) -> - Doc.concat [ - if prefix = "js" then Doc.nil else Doc.text prefix; - Doc.text ("`" ^ txt ^ "`") - ] - | 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 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 = - let isJsFfiImport = List.exists (fun attr -> - match attr with - | ({Location.txt = "ns.jsFfi"}, _) -> true - | _ -> false - ) includeDeclaration.pincl_attributes - in - if isJsFfiImport then - printJsFfiImportDeclaration includeDeclaration cmtTbl - else - 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 printJsFfiImport (valueDescription: Parsetree.value_description) cmtTbl = - let attrs = List.filter (fun attr -> - match attr with - | ({Location.txt = "bs.val" | "genType.import" | "bs.scope" }, _) -> false - | _ -> true - ) valueDescription.pval_attributes in - let (ident, alias) = match valueDescription.pval_prim with - | primitive::_ -> - if primitive <> valueDescription.pval_name.txt then - ( - printIdentLike primitive, - Doc.concat [ - Doc.text " as "; - printIdentLike valueDescription.pval_name.txt; - ] - ) - else - (printIdentLike primitive, Doc.nil) - | _ -> - (printIdentLike valueDescription.pval_name.txt, Doc.nil) - in - Doc.concat [ - printAttributes ~loc:valueDescription.pval_name.loc attrs cmtTbl; - ident; - alias; - Doc.text ": "; - printTypExpr valueDescription.pval_type cmtTbl; - ] - -and printJsFfiImportScope (scope: ParsetreeViewer.jsImportScope) = - match scope with - | JsGlobalImport -> Doc.nil - | JsModuleImport modName -> - Doc.concat [ - Doc.text " from "; - Doc.doubleQuote; - Doc.text modName; - Doc.doubleQuote; - ] - | JsScopedImport idents -> - Doc.concat [ - Doc.text " from "; - Doc.join ~sep:Doc.dot (List.map Doc.text idents) - ] - -and printJsFfiImportDeclaration (includeDeclaration: Parsetree.include_declaration) cmtTbl = - let attrs = List.filter (fun attr -> - match attr with - | ({Location.txt = "ns.jsFfi"}, _) -> false - | _ -> true - ) includeDeclaration.pincl_attributes - in - let imports = ParsetreeViewer.extractValueDescriptionFromModExpr includeDeclaration.pincl_mod in - let scope = match imports with - | vd::_ -> ParsetreeViewer.classifyJsImport vd - | [] -> ParsetreeViewer.JsGlobalImport - in - let scopeDoc = printJsFfiImportScope scope in - Doc.group ( - Doc.concat [ - printAttributes attrs cmtTbl; - Doc.text "import "; - Doc.group ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun vd -> printJsFfiImport vd cmtTbl) imports - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] - ); - scopeDoc; - ] - ) - -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 (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr valueDescription.pval_attributes in - let attrs = printAttributes ~loc:valueDescription.pval_loc attrs cmtTbl in - let header = - if isExternal then "external " else (if hasGenType then "export " 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 (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr td.ptype_attributes in - let attrs = printAttributes ~loc:td.ptype_loc attrs cmtTbl in - let prefix = if i > 0 then - Doc.concat [ - Doc.text "and "; - if hasGenType then Doc.text "export " else Doc.nil - ] - else - Doc.concat [ - Doc.text (if hasGenType then "export type " else "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 (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr td.ptype_attributes in - let attrs = printAttributes ~loc:td.ptype_loc attrs cmtTbl in - let prefix = if i > 0 then - Doc.concat [ - Doc.text "and "; - if hasGenType then Doc.text "export " else Doc.nil - ] - else - Doc.concat [ - Doc.text (if hasGenType then "export type " else "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 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]] - | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, [{ptyp_desc = Ptyp_object (_fields, _openFlag)} as typ]) -> - let bsObject = printTypExpr typ cmtTbl in - begin match typExpr.ptyp_attributes with - | [] -> bsObject - | attrs -> - Doc.concat [ - printAttributes ~inline:true attrs cmtTbl; - printTypExpr typ cmtTbl; - ] - end - | 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 - | [{ - Parsetree.ptyp_desc = - Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, - [{ptyp_desc = Ptyp_object (fields, openFlag)}]) - }] -> - Doc.concat([ - constrName; - Doc.lessThan; - printBsObjectSugar ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ]) - | _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 _ -> 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_object (fields, openFlag) -> - printBsObjectSugar ~inline:false fields openFlag 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 printRowField = function - | Parsetree.Rtag ({txt}, attrs, true, []) -> - Doc.concat [ - printAttributes attrs cmtTbl; - Doc.concat [Doc.text "#"; printIdentLike ~allowUident:true 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 "#"; printIdentLike ~allowUident:true 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.text "| "; cases] in - let openingSymbol = - if closedFlag = Open - then Doc.greaterThan - else if labelsOpt = None - then Doc.nil - else Doc.lessThan in - let hasLabels = labelsOpt <> None && labelsOpt <> Some [] in - let labels = match labelsOpt with - | None - | Some([]) -> - Doc.nil - | Some(labels) -> - Doc.concat (List.map (fun label -> Doc.concat [Doc.line; Doc.text "#" ; printIdentLike ~allowUident:true label] ) labels) - in - let closingSymbol = if hasLabels then Doc.text " >" else Doc.nil in - Doc.group (Doc.concat [Doc.lbracket; openingSymbol; Doc.line; cases; closingSymbol; labels; Doc.line; Doc.rbracket]) - in - let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with - | Ptyp_arrow _ (* es6 arrow types print their own attributes *) - | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, _) -> 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 printBsObjectSugar ~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 -> Doc.dotdot); - 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 - | _ -> Doc.nil - -(* 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 doc = Doc.group ( - Doc.concat [ - uncurried; - attrs; - label; - printTypExpr typ cmtTbl; - optionalIndicator; - ] - ) in - printComments doc cmtTbl typ.ptyp_loc - -and printValueBinding ~recFlag vb cmtTbl i = - let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr vb.pvb_attributes in - let attrs = printAttributes ~loc:vb.pvb_pat.ppat_loc attrs cmtTbl in - let header = - if i == 0 then - Doc.concat [ - if hasGenType then Doc.text "export " else Doc.text "let "; - recFlag - ] else - Doc.concat [ - Doc.text "and "; - if hasGenType then Doc.text "export " else Doc.nil - ] - 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 - if ParsetreeViewer.isPipeExpr vb.pvb_expr then - Doc.customLayout [ - Doc.group ( - Doc.concat [ - attrs; - header; - printPattern vb.pvb_pat cmtTbl; - Doc.text " ="; - Doc.space; - printedExpr; - ] - ); - Doc.group ( - Doc.concat [ - attrs; - header; - printPattern vb.pvb_pat cmtTbl; - 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; - printPattern vb.pvb_pat cmtTbl; - 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 extName = - let doc = Doc.concat [ - Doc.text "%"; - if atModuleLvl then Doc.text "%" else Doc.nil; - Doc.text stringLoc.Location.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 = printLongident constrName.txt 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 "#"; printIdentLike ~allowUident:true label] - | Ppat_variant (label, variantArgs) -> - let variantName = - Doc.concat [Doc.text "#"; printIdentLike ~allowUident:true 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 - Doc.group (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 doc = Doc.group ( - Doc.concat([ - printLidentPath longident cmtTbl; - Doc.text ": "; - Doc.indent( - Doc.concat [ - Doc.softLine; - printPattern pattern cmtTbl; - ] - ) - ]) - ) 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 "#"; printIdentLike ~allowUident:true 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"}, - 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:false - ~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) -> Doc.concat [Doc.text ": "; printTypExpr typ cmtTbl] - | _ -> 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 _ -> - Doc.text "Pexp_send not impemented in printer" - | 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; - ] - ); - if inCallback then Doc.softLine else 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.group ( - 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; - Doc.text txt - | _ -> - let doc = printExpressionWithComments expr cmtTbl in - Doc.concat [Doc.text "${"; 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_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 lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group ( - Doc.concat [ - lhsDoc; - (match op with - | "|." -> Doc.text "->" - | "|>" -> Doc.text " |> " - | _ -> assert false); - 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] - ) -> - 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 - Doc.concat [ - 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 | [] -> 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; - printJsxChildren children cmtTbl; - ] - ); - Doc.line; - Doc.text "" in - let closing = Doc.text "" in - let (children, _) = ParsetreeViewer.collectListExpressions expr in - Doc.group ( - Doc.concat [ - opening; - begin match children with - | [] -> Doc.nil - | children -> - Doc.indent ( - Doc.concat [ - Doc.line; - printJsxChildren children cmtTbl; - ] - ) - end; - Doc.line; - closing; - ] - ) - -and printJsxChildren (children: Parsetree.expression list) cmtTbl = - Doc.group ( - Doc.join ~sep:Doc.line ( - List.map (fun expr -> - let exprDoc = printExpressionWithComments expr cmtTbl in - match Parens.jsxChildExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - addBraces (if Parens.bracedExpr expr then addParens exprDoc else exprDoc) - | Nothing -> exprDoc - ) children - ) - ) - -and printJsxProps args cmtTbl = - let rec loop props args = - match args with - | [] -> (Doc.nil, []) - | [ - (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 - let (children, _) = ParsetreeViewer.collectListExpressions children in - (formattedProps, 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 doc = printExpression expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced(_) -> - (* {(20: int)} make sure that we also protect the expression inside *) - addBraces (if Parens.bracedExpr expr then addParens doc else doc) - | _ -> 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 = - 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:true expr cmtTbl - ] in - let printedArgs = List.map (fun arg -> - printArgument arg cmtTbl - ) args |> Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - 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 cmtTbl in - Doc.customLayout [ - fitsOnOneLine; - breakAllArgs; - ] - -and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = - let rec loop acc args = match args with - | [] -> (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 callback = printPexpFun ~inCallback:true expr cmtTbl in - (Doc.concat (List.rev acc), Doc.concat [lblDoc; callback]) - | arg::args -> - let argDoc = printArgument arg cmtTbl in - loop (Doc.line::Doc.comma::argDoc::acc) args - in - let (printedArgs, callback) = 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; - Doc.softLine; - printedArgs; - Doc.breakableGroup ~forceBreak:true callback; - Doc.softLine; - Doc.rparen; - ] - in - - (* Thing.map( - * arg1, - * arg2, - * arg3, - * (param1, parm2) => doStuff(param1, parm2) - * ) - *) - let breakAllArgs = printArguments ~uncurried args cmtTbl in - 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 "()"}, _)}] -> - if uncurried then Doc.text "(.)" else Doc.text "()" - | [(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 "when "; - 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 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; if inCallback then Doc.space else Doc.line]) - (List.map (fun p -> printExpFunParameter p cmtTbl) parameters) - ] in - Doc.group ( - Doc.concat [ - lparen; - if shouldHug || inCallback then - printedParamaters - else Doc.indent printedParamaters; - if shouldHug || inCallback then - Doc.nil - else - Doc.concat [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 ": "; - printExpressionWithComments expr cmtTbl - ] 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 - 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) - | PTyp typ -> - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.text ": "; - printTypExpr typ cmtTbl; - ]; - ); - Doc.softLine; - Doc.rparen; - ] - | PPat (pat, optExpr) -> - let whenDoc = match optExpr with - | Some expr -> - Doc.concat [ - Doc.line; - Doc.text "when "; - 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; - ] - | _ -> Doc.nil - -and printAttribute ((id, payload) : Parsetree.attribute) cmtTbl = - Doc.group ( - Doc.concat [ - Doc.text "@"; - Doc.text id.txt; - printPayload payload cmtTbl - ] - ) - -and printModExpr modExpr cmtTbl = - let doc = match modExpr.pmod_desc with - | Pmod_ident longidentLoc -> - printLongidentLocation longidentLoc cmtTbl - | 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 = 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; *) - let stringDoc = Doc.toString ~width doc in - print_string stringDoc - -let printInterface ~width (s: Parsetree.signature) comments = - let cmtTbl = CommentTable.make () in - CommentTable.walkSignature s cmtTbl comments; - let stringDoc = Doc.toString ~width (printSignature s cmtTbl) in - print_string stringDoc diff --git a/jscomp/napkin/napkin_printer.mli b/jscomp/napkin/napkin_printer.mli deleted file mode 100644 index 3ed5c79761..0000000000 --- a/jscomp/napkin/napkin_printer.mli +++ /dev/null @@ -1,18 +0,0 @@ - -val printTypeParams : - (Parsetree.core_type * Asttypes.variance) list -> Napkin_comments_table.t -> Napkin_doc.t - -val printLongident : Longident.t -> Napkin_doc.t - -val printTypExpr : Parsetree.core_type -> Napkin_comments_table.t -> Napkin_doc.t - -val addParens : Napkin_doc.t -> Napkin_doc.t - -val printExpression : Parsetree.expression -> Napkin_comments_table.t -> Napkin_doc.t - -val printStructure : Parsetree.structure -> Napkin_comments_table.t -> Napkin_doc.t [@@live] - -val printImplementation : - width:int -> Parsetree.structure -> Napkin_comment.t list -> unit -val printInterface : - width:int -> Parsetree.signature -> Napkin_comment.t list -> unit diff --git a/jscomp/napkin/napkin_reason_binary_driver.ml b/jscomp/napkin/napkin_reason_binary_driver.ml deleted file mode 100644 index e63f3de7c1..0000000000 --- a/jscomp/napkin/napkin_reason_binary_driver.ml +++ /dev/null @@ -1,125 +0,0 @@ - - - -module IO: sig - val readFile: string -> string - val readStdin: unit -> string -end = struct - (* random chunk size: 2^15, TODO: why do we guess randomly? *) - let chunkSize = 32768 - - let readFile filename = - let chan = open_in filename in - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input chan chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr chan; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () - - let readStdin () = - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input stdin chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr stdin; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () -end - -let isReasonDocComment (comment: Napkin_comment.t) = - let content = Napkin_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 = - if String.length filename > 0 then IO.readFile filename - else IO.readStdin () - in - let scanner = Napkin_scanner.make (Bytes.of_string src) filename in - - let rec next prevEndPos scanner = - let (startPos, endPos, token) = Napkin_scanner.scan scanner in - match token with - | Eof -> () - | Comment c -> - Napkin_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 - | _ -> - 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 = { - Napkin_driver.parseImplementation = begin fun ~forPrinter:_ ~filename:_ -> - let magic = Config.ast_impl_magic_number in - ignore ((really_input_string [@doesNotRaise]) stdin (String.length magic)); - let filename = input_value stdin in - let (comments, stringData) = extractConcreteSyntax filename in - let ast = input_value stdin in - let structure = ast - |> Napkin_ast_conversion.replaceStringLiteralStructure stringData - |> Napkin_ast_conversion.normalizeReasonArityStructure ~forPrinter:true - |> Napkin_ast_conversion.structure - in { - Napkin_driver.filename = filename; - source = ""; - parsetree = structure; - diagnostics = (); - invalid = false; - comments = comments; - } - end; - parseInterface = begin fun ~forPrinter:_ ~filename:_ -> - let magic = Config.ast_intf_magic_number in - ignore ((really_input_string [@doesNotRaise]) stdin (String.length magic)); - let filename = input_value stdin in - let (comments, stringData) = extractConcreteSyntax filename in - let ast = input_value stdin in - let signature = ast - |> Napkin_ast_conversion.replaceStringLiteralSignature stringData - |> Napkin_ast_conversion.normalizeReasonAritySignature ~forPrinter:true - |> Napkin_ast_conversion.signature - in { - Napkin_driver.filename; - source = ""; - parsetree = signature; - diagnostics = (); - invalid = false; - comments = comments; - } - end; - stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> "" end; -} diff --git a/jscomp/napkin/napkin_reason_binary_driver.mli b/jscomp/napkin/napkin_reason_binary_driver.mli deleted file mode 100644 index de27855175..0000000000 --- a/jscomp/napkin/napkin_reason_binary_driver.mli +++ /dev/null @@ -1,11 +0,0 @@ -module IO : sig - val readFile : string -> string [@@live] - val readStdin : unit -> string [@@live] -end - -val isReasonDocComment : Napkin_comment.t -> bool [@@live] - -val extractConcreteSyntax : - string -> Napkin_token.Comment.t list * (string * Location.t) list [@@live] - -val parsingEngine : unit Napkin_driver.parsingEngine diff --git a/jscomp/napkin/napkin_reporting.ml b/jscomp/napkin/napkin_reporting.ml deleted file mode 100644 index 189a931683..0000000000 --- a/jscomp/napkin/napkin_reporting.ml +++ /dev/null @@ -1,192 +0,0 @@ -module Token = Napkin_token -module Grammar = Napkin_grammar -module TerminalDoc = struct - type break = - | Never - | Always - - type document = - | Nil - | Group of {break: break; doc: document} - | Text of string - | Indent of {amount: int; doc: document} - | Append of {doc1: document; doc2: document} - - let group ~break doc = Group {break; doc} - let text txt = Text (txt) - let indent i d = Indent {amount = i; doc = d} - let append d1 d2 = Append {doc1 = d1; doc2 = d2} - let nil = Nil - - type stack = - | Empty - | Cons of {doc: document; stack: stack} - - let push stack doc = Cons {doc; stack} - - type mode = - | Flat - | Break - - let toString (* ~width *) (doc : document) = - let buffer = Buffer.create 100 in - let rec loop stack mode offset = - match stack with - | Empty -> () - | Cons {doc; stack = rest} -> - begin match doc with - | Nil -> loop rest mode offset - | Text txt -> - Buffer.add_string buffer txt; - loop rest mode (offset + (String.length txt)) - | Indent {amount = i; doc} -> - let indentation = (String.make [@doesNotRaise]) i ' ' in - Buffer.add_string buffer indentation; - loop (push rest doc) mode (offset + i) - | Append {doc1; doc2} -> - let rest = push rest doc2 in - let rest = push rest - (match mode = Flat with - | true -> Nil - | false -> text "\n") - in - let rest = push rest doc1 in - loop rest mode offset - | Group {break; doc} -> - let rest = push rest doc in - begin match break with - | Always -> loop rest Break offset - | Never -> loop rest Flat offset - end - end - in - loop (push Empty doc) Flat 0; - Buffer.contents buffer -end - -type color = - | NoColor [@live] - | Red [@live] - -type style = { - underline: bool; [@live] - color: color; [@live] -} - -let highlight ~from ~len txt = - if from < 0 || (String.length txt) == 0 || (from >= String.length txt) then txt else - let before = try String.sub txt 0 from with Invalid_argument _ -> "" in - let content = - "\027[31m" ^ (try String.sub txt from len with Invalid_argument _ -> "") ^ "\027[0m" - in - let after = try String.sub txt (from + len) (String.length txt - (from + len)) with Invalid_argument _ -> "" in - before ^ content ^ after - -let underline ~from ~len txt = - let open TerminalDoc in - let indent = (String.make [@doesNotRaise]) from ' ' in - let underline = (String.make [@doesNotRaise]) len '^' in - let line = highlight ~from:0 ~len underline in - group ~break:Always - (append (text txt) (text (indent ^ line))) - -let rec drop n l = - if n == 1 then l - else drop (n - 1) (match l with | _x::xs -> xs | _ -> l) - -let rec take n l = - match l with - | _ when n == 0 -> [] - | [] -> [] - | x::xs -> x::(take (n -1) xs) - -(* TODO: cleanup *) -let renderCodeContext ~missing (src : string) startPos endPos = - let open Lexing in - let startCol = (startPos.pos_cnum - startPos.pos_bol) in - let endCol = endPos.pos_cnum - startPos.pos_cnum + startCol in - let startLine = max 1 (startPos.pos_lnum - 2) in (* 2 lines before *) - let lines = String.split_on_char '\n' src in - let endLine = - let len = List.length lines in - min len (startPos.pos_lnum + 3) (* 2 lines after *) - in - let lines = - lines - |> drop startLine - |> take (endLine - startLine) - |> Array.of_list - in - - let renderLine x ix = - let x = if ix = startPos.pos_lnum then - begin match missing with - | Some _len -> x ^ (String.make 10 ' ' [@doesNotRaise]) - | None -> x - end - else - x - in - - let open TerminalDoc in - let rowNr = - let txt = string_of_int ix in - let len = String.length txt in - if ix = startPos.pos_lnum then - highlight ~from:0 ~len txt - else txt - in - let len = - let len = if endCol >= 0 then - endCol - startCol - else - 1 - in - if (startCol + len) > String.length x then String.length x - startCol - 1 else len - in - let line = - if ix = startPos.pos_lnum then - begin match missing with - | Some len -> - underline - ~from:( - startCol + String.length (String.length (string_of_int ix) |> string_of_int) + 5 - ) ~len x - | None -> - let len = if startCol + len > String.length x then - (String.length x) - startCol - else - len - in - text (highlight ~from:startCol ~len x) - end - else text x - in - group ~break:Never - (append - (append (text rowNr) (text " │")) - (indent 2 line)) - in - - let reportDoc = ref TerminalDoc.nil in - - let linesLen = Array.length lines in - for i = 0 to (linesLen - 1) do - let line = try (Array.get [@doesNotRaise]) lines i with Invalid_argument _ -> "" in - reportDoc := - let open TerminalDoc in - let ix = startLine + i in - group ~break:Always (append !reportDoc (renderLine line ix)) - done; - - TerminalDoc.toString !reportDoc - -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 \ No newline at end of file diff --git a/jscomp/napkin/napkin_scanner.ml b/jscomp/napkin/napkin_scanner.ml deleted file mode 100644 index f4ff344759..0000000000 --- a/jscomp/napkin/napkin_scanner.ml +++ /dev/null @@ -1,729 +0,0 @@ -module CharacterCodes = Napkin_character_codes -module Diagnostics = Napkin_diagnostics -module Token = Napkin_token -module Comment = Napkin_comment -type mode = Template | Jsx | Diamond - -type t = { - filename: string; - src: bytes; - mutable err: - startPos: Lexing.position - -> endPos: Lexing.position - -> Diagnostics.category - -> unit; - mutable ch: int; (* current character *) - mutable offset: int; (* character offset *) - mutable rdOffset: int; (* reading offset (position after current character) *) - 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 setTemplateMode scanner = - scanner.mode <- Template::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 inTemplateMode scanner = match scanner.mode with - | Template::_ -> 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; -} - -let next scanner = - if scanner.rdOffset < (Bytes.length scanner.src) then ( - scanner.offset <- scanner.rdOffset; - let ch = (Bytes.get [@doesNotRaise]) scanner.src scanner.rdOffset in - scanner.rdOffset <- scanner.rdOffset + 1; - scanner.ch <- int_of_char ch - ) else ( - scanner.offset <- Bytes.length scanner.src; - scanner.ch <- -1 - ) - -let peek scanner = - if scanner.rdOffset < (Bytes.length scanner.src) then - int_of_char (Bytes.unsafe_get scanner.src scanner.rdOffset) - else - -1 - -let make b filename = - let scanner = { - filename; - src = b; - err = (fun ~startPos:_ ~endPos:_ _ -> ()); - ch = CharacterCodes.space; - offset = 0; - rdOffset = 0; - lineOffset = 0; - lnum = 1; - mode = []; - } in - next scanner; - scanner - -let skipWhitespace scanner = - let rec scan () = - if scanner.ch == CharacterCodes.space || scanner.ch == CharacterCodes.tab then ( - next scanner; - scan() - ) else if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - next scanner; - scan() - ) else ( - () - ) - in - scan() - -let scanIdentifier scanner = - let startOff = scanner.offset in - while ( - CharacterCodes.isLetter scanner.ch || - CharacterCodes.isDigit scanner.ch || - CharacterCodes.underscore == scanner.ch || - CharacterCodes.singleQuote == scanner.ch - ) do - next scanner - done; - let str = Bytes.sub_string scanner.src startOff (scanner.offset - startOff) in - if CharacterCodes.lbrace == scanner.ch && str = "list" - then begin - next scanner; - Token.lookupKeyword "list{" - end - else Token.lookupKeyword str - -let scanDigits scanner ~base = - if base <= 10 then ( - while CharacterCodes.isDigit scanner.ch || scanner.ch == CharacterCodes.underscore do - next scanner - done; - ) else ( - while CharacterCodes.isHex scanner.ch || scanner.ch == CharacterCodes.underscore do - next scanner - done; - ) - -(* 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, _prefix = if scanner.ch != CharacterCodes.dot then ( - if scanner.ch == CharacterCodes._0 then ( - next scanner; - let ch = CharacterCodes.lower scanner.ch in - if ch == CharacterCodes.Lower.x then ( - next scanner; - 16, 'x' - ) else if ch == CharacterCodes.Lower.o then ( - next scanner; - 8, 'o' - ) else if ch == CharacterCodes.Lower.b then ( - next scanner; - 2, 'b' - ) else ( - 8, '0' - ) - ) else ( - 10, ' ' - ) - ) else (10, ' ') - in - scanDigits scanner ~base; - - (* *) - let isFloat = if CharacterCodes.dot == scanner.ch then ( - next scanner; - scanDigits scanner ~base; - true - ) else ( - false - ) in - - (* exponent part *) - let isFloat = - if let exp = CharacterCodes.lower scanner.ch in - exp == CharacterCodes.Lower.e || exp == CharacterCodes.Lower.p - then ( - next scanner; - if scanner.ch == CharacterCodes.plus || scanner.ch == CharacterCodes.minus then - next scanner; - scanDigits scanner ~base; - true - ) else - isFloat - in - let literal = - Bytes.sub_string scanner.src startOff (scanner.offset - startOff) - in - - (* suffix *) - let suffix = - if scanner.ch >= CharacterCodes.Lower.g && scanner.ch <= CharacterCodes.Lower.z - || scanner.ch >= CharacterCodes.Upper.g && scanner.ch <= CharacterCodes.Upper.z - then ( - let ch = scanner.ch in - next scanner; - Some (Char.unsafe_chr ch) - ) else - None - in - if isFloat then - Token.Float {f = literal; suffix} - else - Token.Int {i = literal; suffix} - -let scanExoticIdentifier scanner = - next scanner; - let buffer = Buffer.create 20 in - let startPos = position scanner in - - let rec scan () = - if scanner.ch == CharacterCodes.eof then - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?") - else if scanner.ch == CharacterCodes.doubleQuote then ( - next scanner - ) else if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?"); - next scanner - ) else ( - Buffer.add_char buffer ((Char.chr [@doesNotRaise]) scanner.ch); - next scanner; - scan() - ) - in - scan(); - Token.Lident (Buffer.contents buffer) - -let scanStringEscapeSequence ~startPos scanner = - (* \ already consumed *) - if CharacterCodes.Lower.n == scanner.ch - || CharacterCodes.Lower.t == scanner.ch - || CharacterCodes.Lower.b == scanner.ch - || CharacterCodes.Lower.r == scanner.ch - || CharacterCodes.backslash == scanner.ch - || CharacterCodes.space == scanner.ch - || CharacterCodes.singleQuote == scanner.ch - || CharacterCodes.doubleQuote == scanner.ch - then - next scanner - else - let (n, base, max) = - if CharacterCodes.isDigit scanner.ch then - (* decimal *) - (3, 10, 255) - else if scanner.ch == CharacterCodes.Lower.o then - (* octal *) - let () = next scanner in - (3, 8, 255) - else if scanner.ch == CharacterCodes.Lower.x then - (* hex *) - let () = next scanner in - (2, 16, 255) - else - (* 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 () = *) - (* let msg = if scanner.ch == -1 then *) - (* "unclosed escape sequence" *) - (* else "unknown escape sequence" *) - (* in *) - (* scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) *) - (* in *) - (-1, -1, -1) - in - if n < 0 then () - else - let rec while_ n x = - if n == 0 then x - else - let d = CharacterCodes.digitValue scanner.ch in - if d >= base then - let pos = position scanner in - let msg = if scanner.ch == -1 then - "unclosed escape sequence" - else "unknown escape sequence" - in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); - -1 - else - let () = next scanner in - while_ (n - 1) (x * base + d) - in - let x = while_ 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); - () - -let scanString scanner = - let offs = scanner.offset in - - let startPos = position scanner in - let rec scan () = - if scanner.ch == CharacterCodes.eof then - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedString - else if scanner.ch == CharacterCodes.doubleQuote then ( - next scanner; - ) else if scanner.ch == CharacterCodes.backslash then ( - let startPos = position scanner in - next scanner; - scanStringEscapeSequence ~startPos scanner; - scan () - ) else if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - next scanner; - scan () - ) else ( - next scanner; - scan () - ) - in - scan (); - Token.String (Bytes.sub_string scanner.src offs (scanner.offset - offs - 1)) - -(* I wonder if this gets inlined *) -let convertNumber scanner ~n ~base = - let x = ref 0 in - for _ = n downto 1 do - let d = CharacterCodes.digitValue scanner.ch in - x := (!x * base) + d; - next scanner - done; - !x - -let scanEscape scanner = - (* let offset = scanner.offset in *) - let c = match scanner.ch with - | 98 (* b *) -> next scanner; '\008' - | 110 (* n *) -> next scanner; '\010' - | 114 (* r *) -> next scanner; '\013' - | 116 (* t *) -> next scanner; '\009' - | ch when CharacterCodes.isDigit ch -> - let x = convertNumber scanner ~n:3 ~base:10 in - (Char.chr [@doesNotRaise]) x - | ch when ch == CharacterCodes.Lower.x -> - next scanner; - let x = convertNumber scanner ~n:2 ~base:16 in - (Char.chr [@doesNotRaise]) x - | ch when ch == CharacterCodes.Lower.o -> - next scanner; - let x = convertNumber scanner ~n:3 ~base:8 in - (Char.chr [@doesNotRaise]) x - | ch -> - next scanner; - (Char.chr [@doesNotRaise]) ch - in - next scanner; (* Consume \' *) - Token.Character c - -let scanSingleLineComment scanner = - let startOff = scanner.offset in - let startPos = position scanner in - while not (CharacterCodes.isLineBreak scanner.ch) && scanner.ch >= 0 do - next scanner - done; - let endPos = position scanner in - Token.Comment ( - Comment.makeSingleLineComment - ~loc:(Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false}) - (Bytes.sub_string scanner.src startOff (scanner.offset - startOff)) - ) - -let scanMultiLineComment scanner = - let startOff = scanner.offset in - let startPos = position scanner in - let rec scan ~depth () = - if scanner.ch == CharacterCodes.asterisk && - peek scanner == CharacterCodes.forwardslash then ( - next scanner; - next scanner; - if depth > 0 then scan ~depth:(depth - 1) () else () - ) else if scanner.ch == CharacterCodes.eof then ( - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment - ) else if scanner.ch == CharacterCodes.forwardslash - && peek scanner == CharacterCodes. asterisk then ( - next scanner; - next scanner; - scan ~depth:(depth + 1) () - ) else ( - if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - ); - next scanner; - scan ~depth () - ) - in - scan ~depth:0 (); - Token.Comment ( - Comment.makeMultiLineComment - ~loc:(Location.{loc_start = startPos; loc_end = (position scanner); loc_ghost = false}) - (Bytes.sub_string scanner.src startOff (scanner.offset - 2 - startOff)) - ) - -let scanTemplate scanner = - let startOff = scanner.offset in - let startPos = position scanner in - - let rec scan () = - if scanner.ch == CharacterCodes.eof then ( - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; - popMode scanner Template; - Token.TemplateTail( - Bytes.sub_string scanner.src startOff (scanner.offset - 2 - startOff) - ) - ) - else if scanner.ch == CharacterCodes.backslash then ( - next scanner; - if scanner.ch == CharacterCodes.backtick - || scanner.ch == CharacterCodes.backslash - || scanner.ch == CharacterCodes.dollar - then next scanner; - scan() - ) else if scanner.ch == CharacterCodes.backtick then ( - next scanner; - let contents = - Bytes.sub_string scanner.src startOff (scanner.offset - 1 - startOff) - in - popMode scanner Template; - Token.TemplateTail contents - ) else if scanner.ch == CharacterCodes.dollar && - peek scanner == CharacterCodes.lbrace - then ( - next scanner; (* consume $ *) - next scanner; (* consume { *) - let contents = - Bytes.sub_string scanner.src startOff (scanner.offset - 2 - startOff) - in - popMode scanner Template; - Token.TemplatePart contents - ) else ( - if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - ); - next scanner; - scan() - ) - in - scan() - -let rec scan scanner = - if not (inTemplateMode scanner) then skipWhitespace scanner; - let startPos = position scanner in - let ch = scanner.ch in - let token = if inTemplateMode scanner then - scanTemplate scanner - else if ch == CharacterCodes.underscore then ( - let nextCh = peek scanner in - if nextCh == CharacterCodes.underscore || CharacterCodes.isDigit nextCh || CharacterCodes.isLetter nextCh then - scanIdentifier scanner - else ( - next scanner; - Token.Underscore - ) - ) else if CharacterCodes.isLetter ch then - scanIdentifier scanner - else if CharacterCodes.isDigit ch then - scanNumber scanner - else begin - next scanner; - if ch == CharacterCodes.dot then - if scanner.ch == CharacterCodes.dot then ( - next scanner; - if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.DotDotDot - ) else ( - Token.DotDot - ) - ) else ( - Token.Dot - ) - else if ch == CharacterCodes.doubleQuote then - scanString scanner - else if ch == CharacterCodes.singleQuote then ( - if scanner.ch == CharacterCodes.backslash - && not ((peek scanner) == CharacterCodes.doubleQuote) (* start of exotic ident *) - then ( - next scanner; - scanEscape scanner - ) else if (peek scanner) == CharacterCodes.singleQuote then ( - let ch = scanner.ch in - next scanner; - next scanner; - Token.Character ((Char.chr [@doesNotRaise]) ch) - ) else ( - SingleQuote - ) - ) else if ch == CharacterCodes.bang then - if scanner.ch == CharacterCodes.equal then ( - next scanner; - if scanner.ch == CharacterCodes.equal then ( - next scanner; - Token.BangEqualEqual - ) else ( - Token.BangEqual - ) - ) else ( - Token.Bang - ) - else if ch == CharacterCodes.semicolon then - Token.Semicolon - else if ch == CharacterCodes.equal then ( - if scanner.ch == CharacterCodes.greaterThan then ( - next scanner; - Token.EqualGreater - ) else if scanner.ch == CharacterCodes.equal then ( - next scanner; - if scanner.ch == CharacterCodes.equal then ( - next scanner; - Token.EqualEqualEqual - ) else ( - Token.EqualEqual - ) - ) else ( - Token.Equal - ) - ) else if ch == CharacterCodes.bar then - if scanner.ch == CharacterCodes.bar then ( - next scanner; - Token.Lor - ) else if scanner.ch == CharacterCodes.greaterThan then ( - next scanner; - Token.BarGreater - ) else ( - Token.Bar - ) - else if ch == CharacterCodes.ampersand then - if scanner.ch == CharacterCodes.ampersand then ( - next scanner; - Token.Land - ) else ( - Token.Band - ) - else if ch == CharacterCodes.lparen then - Token.Lparen - else if ch == CharacterCodes.rparen then - Token.Rparen - else if ch == CharacterCodes.lbracket then - Token.Lbracket - else if ch == CharacterCodes.rbracket then - Token.Rbracket - else if ch == CharacterCodes.lbrace then - Token.Lbrace - else if ch == CharacterCodes.rbrace then - Token.Rbrace - else if ch == CharacterCodes.comma then - Token.Comma - else if ch == CharacterCodes.colon then - if scanner.ch == CharacterCodes.equal then( - next scanner; - Token.ColonEqual - ) else if (scanner.ch == CharacterCodes.greaterThan) then ( - next scanner; - Token.ColonGreaterThan - ) else ( - Token.Colon - ) - else if ch == CharacterCodes.backslash then - scanExoticIdentifier scanner - else if ch == CharacterCodes.forwardslash then - if scanner.ch == CharacterCodes.forwardslash then ( - next scanner; - scanSingleLineComment scanner - ) else if (scanner.ch == CharacterCodes.asterisk) then ( - next scanner; - scanMultiLineComment scanner - ) else if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.ForwardslashDot - ) else ( - Token.Forwardslash - ) - else if ch == CharacterCodes.minus then - if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.MinusDot - ) else if scanner.ch == CharacterCodes.greaterThan then ( - next scanner; - Token.MinusGreater; - ) else ( - Token.Minus - ) - else if ch == CharacterCodes.plus then - if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.PlusDot - ) else if scanner.ch == CharacterCodes.plus then ( - next scanner; - Token.PlusPlus - ) else if scanner.ch == CharacterCodes.equal then ( - next scanner; - Token.PlusEqual - ) else ( - Token.Plus - ) - else if ch == CharacterCodes.greaterThan then - if scanner.ch == CharacterCodes.equal && not (inDiamondMode scanner) then ( - next scanner; - Token.GreaterEqual - ) else ( - Token.GreaterThan - ) - else if ch == CharacterCodes.lessThan then - (* 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 < - * 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 == CharacterCodes.forwardslash then - let () = next scanner in - Token.LessThanSlash - else - Token.LessThan - -(* If an operator has whitespace around both sides, it's a binary operator *) -let isBinaryOp src startCnum endCnum = - if startCnum == 0 then false - else - let leftOk = - let c = - (startCnum - 1) - |> (Bytes.get [@doesNotRaise]) src - |> Char.code - in - c == CharacterCodes.space || - c == CharacterCodes.tab || - CharacterCodes.isLineBreak c - in - let rightOk = - let c = - if endCnum == Bytes.length src then -1 - else endCnum |> (Bytes.get [@doesNotRaise]) src |> Char.code - in - c == CharacterCodes.space || - c == CharacterCodes.tab || - CharacterCodes.isLineBreak c || - c == CharacterCodes.eof - in - leftOk && rightOk \ No newline at end of file diff --git a/jscomp/napkin/napkin_scanner.mli b/jscomp/napkin/napkin_scanner.mli deleted file mode 100644 index 0c4286031e..0000000000 --- a/jscomp/napkin/napkin_scanner.mli +++ /dev/null @@ -1,32 +0,0 @@ - -type mode = Template | Jsx | Diamond - - type t = { - filename: string; - src: bytes; - mutable err: - startPos: Lexing.position - -> endPos: Lexing.position - -> Napkin_diagnostics.category - -> unit; - mutable ch: int; (* current character *) - mutable offset: int; (* character offset *) - mutable rdOffset: int; (* reading offset (position after current character) *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; - } - - val make: bytes -> string -> t - - (* TODO: make this a record *) - val scan: t -> (Lexing.position * Lexing.position * Napkin_token.t) - - val isBinaryOp: bytes -> int -> int -> bool - - val setTemplateMode: t -> unit - val setJsxMode: t -> unit - val setDiamondMode: t -> unit - val popMode: t -> mode -> unit - - val reconsiderLessThan: t -> Napkin_token.t \ No newline at end of file diff --git a/jscomp/napkin/napkin_token.ml b/jscomp/napkin/napkin_token.ml deleted file mode 100644 index 4d8aa63023..0000000000 --- a/jscomp/napkin/napkin_token.ml +++ /dev/null @@ -1,223 +0,0 @@ - -module Comment = Napkin_comment -module CharacterCodes = Napkin_character_codes - -type t = - | Open - | True | False - | Character of char - | Int of {i: string; suffix: char option} - | Float of {f: string; suffix: char option} - | String of string - | Lident of string - | Uident of string - | As - | Dot | DotDot | DotDotDot - | Bang - | Semicolon - | Let - | And - | Rec - | Underscore - | SingleQuote - | Equal | EqualEqual | EqualEqualEqual - | Bar - | Lparen - | Rparen - | Lbracket - | Rbracket - | Lbrace - | Rbrace - | Colon - | Comma - | Eof - | Exception - | Backslash [@live] - | Forwardslash | ForwardslashDot - | Asterisk | AsteriskDot | Exponentiation - | Minus | MinusDot - | Plus | PlusDot | PlusPlus | PlusEqual - | ColonGreaterThan - | GreaterThan - | LessThan - | LessThanSlash - | Hash | HashEqual - | Assert - | Lazy - | Tilde - | Question - | If | Else | For | In | To | Downto | While | Switch - | When - | EqualGreater | MinusGreater - | External - | Typ - | Private - | Mutable - | Constraint - | Include - | Module - | Of - | With - | Land | Lor - | Band (* Bitwise and: & *) - | BangEqual | BangEqualEqual - | LessEqual | GreaterEqual - | ColonEqual - | At | AtAt - | Percent | PercentPercent - | Comment of Comment.t - | List - | TemplateTail of string - | TemplatePart of string - | Backtick - | BarGreater - | Try | Catch - | Import - | Export - -let precedence = function - | HashEqual | ColonEqual -> 1 - | Lor -> 2 - | Land -> 3 - | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan - | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> 4 - | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 - | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 - | Exponentiation -> 7 - | MinusGreater -> 8 - | Dot -> 9 - | _ -> 0 - -let toString = function - | Open -> "open" - | True -> "true" | False -> "false" - | Character c -> "character '" ^ (Char.escaped c) ^ "'" - | String s -> "string \"" ^ s ^ "\"" - | Lident str -> "lident \"" ^ str ^ "\"" - | Uident str -> "uident \"" ^ str ^ "\"" - | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int {i} -> "int " ^ i - | Float {f} -> "Float: " ^ f - | Bang -> "!" - | Semicolon -> ";" - | Let -> "let" - | And -> "and" - | Rec -> "rec" - | Underscore -> "_" - | SingleQuote -> "'" - | Equal -> "=" | EqualEqual -> "==" | EqualEqualEqual -> "===" - | Eof -> "eof" - | Bar -> "|" - | As -> "as" - | Lparen -> "(" | Rparen -> ")" - | Lbracket -> "[" | Rbracket -> "]" - | Lbrace -> "{" | Rbrace -> "}" - | ColonGreaterThan -> ":>" - | Colon -> ":" - | Comma -> "," - | Minus -> "-" | MinusDot -> "-." - | Plus -> "+" | PlusDot -> "+." | PlusPlus -> "++" | PlusEqual -> "+=" - | Backslash -> "\\" - | Forwardslash -> "/" | ForwardslashDot -> "/." - | Exception -> "exception" - | Hash -> "#" | HashEqual -> "#=" - | GreaterThan -> ">" - | LessThan -> "<" - | LessThanSlash -> " "*" | AsteriskDot -> "*." | Exponentiation -> "**" - | Assert -> "assert" - | Lazy -> "lazy" - | Tilde -> "tilde" - | Question -> "?" - | If -> "if" - | Else -> "else" - | For -> "for" - | In -> "in" - | To -> "to" - | Downto -> "downto" - | While -> "while" - | Switch -> "switch" - | When -> "when" - | EqualGreater -> "=>" | MinusGreater -> "->" - | External -> "external" - | Typ -> "type" - | Private -> "private" - | Constraint -> "constraint" - | Mutable -> "mutable" - | Include -> "include" - | Module -> "module" - | Of -> "of" - | With -> "with" - | Lor -> "||" - | Band -> "&" | Land -> "&&" - | BangEqual -> "!=" | BangEqualEqual -> "!==" - | GreaterEqual -> ">=" | LessEqual -> "<=" - | ColonEqual -> ":=" - | At -> "@" | AtAt -> "@@" - | Percent -> "%" | PercentPercent -> "%%" - | Comment c -> "Comment(" ^ (Comment.toString c) ^ ")" - | List -> "list{" - | TemplatePart text -> text ^ "${" - | TemplateTail text -> "TemplateTail(" ^ text ^ ")" - | Backtick -> "`" - | BarGreater -> "|>" - | Try -> "try" | Catch -> "catch" - | Import -> "import" - | Export -> "export" - -let keywordTable = function -| "true" -> True -| "false" -> False -| "open" -> Open -| "let" -> Let -| "rec" -> Rec -| "and" -> And -| "as" -> As -| "exception" -> Exception -| "assert" -> Assert -| "lazy" -> Lazy -| "if" -> If -| "else" -> Else -| "for" -> For -| "in" -> In -| "to" -> To -| "downto" -> Downto -| "while" -> While -| "switch" -> Switch -| "when" -> When -| "external" -> External -| "type" -> Typ -| "private" -> Private -| "mutable" -> Mutable -| "constraint" -> Constraint -| "include" -> Include -| "module" -> Module -| "of" -> Of -| "list{" -> List -| "with" -> With -| "try" -> Try -| "catch" -> Catch -| "import" -> Import -| "export" -> Export -| _ -> raise Not_found -[@@raises Not_found] - -let isKeyword = function - | True | False | Open | Let | Rec | And | As - | Exception | Assert | Lazy | If | Else | For | In | To - | Downto | While | Switch | When | External | Typ | Private - | Mutable | Constraint | Include | Module | Of - | Land | Lor | List | With - | Try | Catch | Import | Export -> true - | _ -> false - -let lookupKeyword str = - try keywordTable str with - | Not_found -> - if CharacterCodes.isUpperCase (int_of_char (str.[0] [@doesNotRaise])) then - Uident str - else Lident str - -let isKeywordTxt str = - try let _ = keywordTable str in true with - | Not_found -> false \ No newline at end of file