+ * reconsiderLessThan peeks at the next token and
+ * determines the correct token to disambiguate *)
+ let token = Scanner.reconsiderLessThan p.scanner in
+ if token = LessThan then
+ let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in
+ loop p (child::children)
+ else (* LessThanSlash *)
+ let () = p.token <- token in
+ let () = Scanner.popMode p.scanner Jsx in
+ List.rev children
+ | token when Grammar.isJsxChildStart token ->
+ let () = Scanner.popMode p.scanner Jsx in
+ let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in
+ loop p (child::children)
+ | _ ->
+ Scanner.popMode p.scanner Jsx;
+ List.rev children
+ in
+ match p.Parser.token with
+ | DotDotDot ->
+ Parser.next p;
+ (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p])
+ | _ -> (false, loop p [])
+
+and parseBracedOrRecordExpr p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lbrace p;
+ match p.Parser.token with
+ | Rbrace ->
+ Parser.err p (Diagnostics.unexpected Rbrace p.breadcrumbs);
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ Ast_helper.Exp.construct ~attrs:[braces] ~loc
+ (Location.mkloc (Longident.Lident "()") loc) None
+ | DotDotDot ->
+ (* beginning of record spread, parse record *)
+ Parser.next p;
+ let spreadExpr = parseConstrainedOrCoercedExpr p in
+ Parser.expect Comma p;
+ let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in
+ Parser.expect Rbrace p;
+ expr
+ | String s ->
+ let s = if p.mode = ParseForTypeChecker then parseStringLiteral s else s in
+ let field =
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Location.mkloc (Longident.Lident s) loc
+ in
+ begin match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ let fieldExpr = parseExpr p in
+ Parser.optional p Comma |> ignore;
+ let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in
+ Parser.expect Rbrace p;
+ expr
+ | _ ->
+ let constant = Ast_helper.Exp.constant ~loc:field.loc (Parsetree.Pconst_string(s, None)) in
+ let a = parsePrimaryExpr ~operand:constant p in
+ let e = parseBinaryExpr ~a p 1 in
+ let e = parseTernaryExpr e p in
+ begin match p.Parser.token with
+ | Semicolon ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with Parsetree.pexp_attributes = braces::expr.Parsetree.pexp_attributes}
+ | Rbrace ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {e with pexp_attributes = braces::e.pexp_attributes}
+ | _ ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ end
+ end
+ | Uident _ | Lident _ ->
+ let valueOrConstructor = parseValueOrConstructor p in
+ begin match valueOrConstructor.pexp_desc with
+ | Pexp_ident pathIdent ->
+ let identEndPos = p.prevEndPos in
+ begin match p.Parser.token with
+ | Comma ->
+ Parser.next p;
+ let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in
+ Parser.expect Rbrace p;
+ expr
+ | Colon ->
+ Parser.next p;
+ let fieldExpr = parseExpr p in
+ begin match p.token with
+ | Rbrace ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None
+ | _ ->
+ Parser.expect Comma p;
+ let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in
+ Parser.expect Rbrace p;
+ expr
+ end
+ (* error case *)
+ | Lident _ ->
+ if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then (
+ Parser.expect Comma p;
+ let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in
+ Parser.expect Rbrace p;
+ expr
+ ) else (
+ Parser.expect Colon p;
+ let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in
+ Parser.expect Rbrace p;
+ expr
+ )
+ | Semicolon ->
+ let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ | Rbrace ->
+ Parser.next p;
+ let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ | EqualGreater ->
+ let loc = mkLoc startPos identEndPos in
+ let ident = Location.mkloc (Longident.last pathIdent.txt) loc in
+ let a = parseEs6ArrowExpression
+ ~parameters:[TermParameter {
+ uncurried = false;
+ attrs = [];
+ label = Asttypes.Nolabel;
+ expr = None;
+ pat = Ast_helper.Pat.var ident;
+ pos = startPos;
+ }]
+ p
+ in
+ let e = parseBinaryExpr ~a p 1 in
+ let e = parseTernaryExpr e p in
+ begin match p.Parser.token with
+ | Semicolon ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ | Rbrace ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {e with pexp_attributes = braces::e.pexp_attributes}
+ | _ ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ end
+ | _ ->
+ Parser.leaveBreadcrumb p Grammar.ExprBlock;
+ let a = parsePrimaryExpr ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) p in
+ let e = parseBinaryExpr ~a p 1 in
+ let e = parseTernaryExpr e p in
+ Parser.eatBreadcrumb p;
+ begin match p.Parser.token with
+ | Semicolon ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ | Rbrace ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {e with pexp_attributes = braces::e.pexp_attributes}
+ | _ ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ end
+ end
+ | _ ->
+ Parser.leaveBreadcrumb p Grammar.ExprBlock;
+ let a = parsePrimaryExpr ~operand:valueOrConstructor p in
+ let e = parseBinaryExpr ~a p 1 in
+ let e = parseTernaryExpr e p in
+ Parser.eatBreadcrumb p;
+ begin match p.Parser.token with
+ | Semicolon ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ | Rbrace ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {e with pexp_attributes = braces::e.pexp_attributes}
+ | _ ->
+ let expr = parseExprBlock ~first:e p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+ end
+ end
+ | _ ->
+ let expr = parseExprBlock p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let braces = makeBracesAttr loc in
+ {expr with pexp_attributes = braces::expr.pexp_attributes}
+
+and parseRecordRowWithStringKey p =
+ match p.Parser.token with
+ | String s ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ let field = Location.mkloc (Longident.Lident s) loc in
+ begin match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ let fieldExpr = parseExpr p in
+ Some (field, fieldExpr)
+ | _ ->
+ Some (field, Ast_helper.Exp.ident ~loc:field.loc field)
+ end
+ | _ -> None
+
+and parseRecordRow p =
+ let () = match p.Parser.token with
+ | Token.DotDotDot ->
+ Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread);
+ Parser.next p;
+ | _ -> ()
+ in
+ match p.Parser.token with
+ | Lident _ | Uident _ ->
+ let field = parseValuePath p in
+ begin match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ let fieldExpr = parseExpr p in
+ Some (field, fieldExpr)
+ | _ ->
+ Some (field, Ast_helper.Exp.ident ~loc:field.loc field)
+ end
+ | _ -> None
+
+and parseRecordExprWithStringKeys ~startPos firstRow p =
+ let rows = firstRow::(
+ parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey ~closing:Rbrace ~f:parseRecordRowWithStringKey p
+ ) in
+ let loc = mkLoc startPos p.endPos in
+ let recordStrExpr = Ast_helper.Str.eval ~loc (
+ Ast_helper.Exp.record ~loc rows None
+ ) in
+ Ast_helper.Exp.extension ~loc
+ (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr])
+
+and parseRecordExpr ~startPos ?(spread=None) rows p =
+ let exprs =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.RecordRows
+ ~closing:Rbrace
+ ~f:parseRecordRow p
+ in
+ let rows = List.concat [rows; exprs] in
+ let () = match rows with
+ | [] ->
+ let msg = "Record spread needs at least one field that's updated" in
+ Parser.err p (Diagnostics.message msg);
+ | _rows -> ()
+ in
+ let loc = mkLoc startPos p.endPos in
+ Ast_helper.Exp.record ~loc rows spread
+
+
+and parseNewlineOrSemicolonExprBlock p =
+ match p.Parser.token with
+ | Semicolon ->
+ Parser.next p
+ | token when Grammar.isBlockExprStart token ->
+ if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ()
+ else
+ Parser.err
+ ~startPos:p.prevEndPos
+ ~endPos: p.endPos
+ p
+ (Diagnostics.message "consecutive expressions on a line must be separated by ';' or a newline")
+ | _ -> ()
+
+and parseExprBlockItem p =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Module ->
+ Parser.next p;
+ begin match p.token with
+ | Lparen ->
+ let expr = parseFirstClassModuleExpr ~startPos p in
+ let a = parsePrimaryExpr ~operand:expr p in
+ let expr = parseBinaryExpr ~a p 1 in
+ parseTernaryExpr expr p
+ | _ ->
+ let name = match p.Parser.token with
+ | Uident ident ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Location.mkloc ident loc
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Location.mknoloc "_"
+ in
+ let body = parseModuleBindingBody p in
+ parseNewlineOrSemicolonExprBlock p;
+ let expr = parseExprBlock p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.letmodule ~loc name body expr
+ end
+ | Exception ->
+ let extensionConstructor = parseExceptionDef ~attrs p in
+ parseNewlineOrSemicolonExprBlock p;
+ let blockExpr = parseExprBlock p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr
+ | Open ->
+ let od = parseOpenDescription ~attrs p in
+ parseNewlineOrSemicolonExprBlock p;
+ let blockExpr = parseExprBlock p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr
+ | Let ->
+ let (recFlag, letBindings) = parseLetBindings ~attrs p in
+ parseNewlineOrSemicolonExprBlock p;
+ let next = if Grammar.isBlockExprStart p.Parser.token then
+ parseExprBlock p
+ else
+ let loc = mkLoc p.startPos p.endPos in
+ Ast_helper.Exp.construct ~loc
+ (Location.mkloc (Longident.Lident "()") loc) None
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.let_ ~loc recFlag letBindings next
+ | _ ->
+ let e1 =
+ let expr = parseExpr p in
+ {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]}
+ in
+ parseNewlineOrSemicolonExprBlock p;
+ if Grammar.isBlockExprStart p.Parser.token then
+ let e2 = parseExprBlock p in
+ let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in
+ Ast_helper.Exp.sequence ~loc e1 e2
+ else e1
+
+(* blockExpr ::= expr
+ * | expr ;
+ * | expr ; blockExpr
+ * | module ... ; blockExpr
+ * | open ... ; blockExpr
+ * | exception ... ; blockExpr
+ * | let ...
+ * | let ... ;
+ * | let ... ; blockExpr
+ *
+ * note: semi should be made optional
+ * a block of expression is always
+ *)
+and parseExprBlock ?first p =
+ Parser.leaveBreadcrumb p Grammar.ExprBlock;
+ let item = match first with
+ | Some e -> e
+ | None -> parseExprBlockItem p
+ in
+ parseNewlineOrSemicolonExprBlock p;
+ let blockExpr = if Grammar.isBlockExprStart p.Parser.token then
+ let next = parseExprBlockItem p in
+ let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in
+ Ast_helper.Exp.sequence ~loc item next
+ else
+ item
+ in
+ Parser.eatBreadcrumb p;
+ overParseConstrainedOrCoercedOrArrowExpression p blockExpr
+
+and parseTryExpression p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Try p;
+ let expr = parseExpr ~context:WhenExpr p in
+ Parser.expect Res_token.catch p;
+ Parser.expect Lbrace p;
+ let cases = parsePatternMatching p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.try_ ~loc expr cases
+
+and parseIfCondition p =
+ Parser.leaveBreadcrumb p Grammar.IfCondition;
+ (* doesn't make sense to try es6 arrow here? *)
+ let conditionExpr = parseExpr ~context:WhenExpr p in
+ Parser.eatBreadcrumb p;
+ conditionExpr
+
+and parseThenBranch p =
+ Parser.leaveBreadcrumb p IfBranch;
+ Parser.expect Lbrace p;
+ let thenExpr = parseExprBlock p in
+ Parser.expect Rbrace p;
+ Parser.eatBreadcrumb p;
+ thenExpr
+
+and parseElseBranch p =
+ Parser.expect Lbrace p;
+ let blockExpr = parseExprBlock p in
+ Parser.expect Rbrace p;
+ blockExpr;
+
+and parseIfExpr startPos p =
+ let conditionExpr = parseIfCondition p in
+ let thenExpr = parseThenBranch p in
+ let elseExpr = match p.Parser.token with
+ | Else ->
+ Parser.endRegion p;
+ Parser.leaveBreadcrumb p Grammar.ElseBranch;
+ Parser.next p;
+ Parser.beginRegion p;
+ let elseExpr = match p.token with
+ | If ->
+ parseIfOrIfLetExpression p
+ | _ ->
+ parseElseBranch p
+ in
+ Parser.eatBreadcrumb p;
+ Parser.endRegion p;
+ Some elseExpr
+ | _ ->
+ Parser.endRegion p;
+ None
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr
+
+and parseIfLetExpr startPos p =
+ let pattern = parsePattern p in
+ Parser.expect Equal p;
+ let conditionExpr = parseIfCondition p in
+ let thenExpr = parseThenBranch p in
+ let elseExpr = match p.Parser.token with
+ | Else ->
+ Parser.endRegion p;
+ Parser.leaveBreadcrumb p Grammar.ElseBranch;
+ Parser.next p;
+ Parser.beginRegion p;
+ let elseExpr = match p.token with
+ | If ->
+ parseIfOrIfLetExpression p
+ | _ ->
+ parseElseBranch p
+ in
+ Parser.eatBreadcrumb p;
+ Parser.endRegion p;
+ elseExpr
+ | _ ->
+ Parser.endRegion p;
+ let startPos = p.Parser.startPos in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.match_ ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] ~loc conditionExpr [
+ Ast_helper.Exp.case pattern thenExpr;
+ Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr;
+ ]
+
+and parseIfOrIfLetExpression p =
+ Parser.beginRegion p;
+ Parser.leaveBreadcrumb p Grammar.ExprIf;
+ let startPos = p.Parser.startPos in
+ Parser.expect If p;
+ let expr = match p.Parser.token with
+ | Let ->
+ Parser.next p;
+ let ifLetExpr = parseIfLetExpr startPos p in
+ Parser.err
+ ~startPos:ifLetExpr.pexp_loc.loc_start
+ ~endPos:ifLetExpr.pexp_loc.loc_end
+ p
+ (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr));
+ ifLetExpr
+ | _ ->
+ parseIfExpr startPos p
+ in
+ Parser.eatBreadcrumb p;
+ expr;
+
+and parseForRest hasOpeningParen pattern startPos p =
+ Parser.expect In p;
+ let e1 = parseExpr p in
+ let direction = match p.Parser.token with
+ | Lident "to" -> Asttypes.Upto
+ | Lident "downto" -> Asttypes.Downto
+ | token ->
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ Asttypes.Upto
+ in
+ Parser.next p;
+ let e2 = parseExpr ~context:WhenExpr p in
+ if hasOpeningParen then Parser.expect Rparen p;
+ Parser.expect Lbrace p;
+ let bodyExpr = parseExprBlock p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.for_ ~loc pattern e1 e2 direction bodyExpr
+
+and parseForExpression p =
+ let startPos = p.Parser.startPos in
+ Parser.leaveBreadcrumb p Grammar.ExprFor;
+ Parser.expect For p;
+ Parser.beginRegion p;
+ let forExpr = match p.token with
+ | Lparen ->
+ let lparen = p.startPos in
+ Parser.next p;
+ begin match p.token with
+ | Rparen ->
+ Parser.next p;
+ let unitPattern =
+ let loc = mkLoc lparen p.prevEndPos in
+ let lid = Location.mkloc (Longident.Lident "()") loc in
+ Ast_helper.Pat.construct lid None
+ in
+ parseForRest false (parseAliasPattern ~attrs:[] unitPattern p) startPos p
+ | _ ->
+ Parser.leaveBreadcrumb p Grammar.Pattern;
+ let pat = parsePattern p in
+ Parser.eatBreadcrumb p;
+ begin match p.token with
+ | Comma ->
+ Parser.next p;
+ let tuplePattern =
+ parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p
+ in
+ let pattern = parseAliasPattern ~attrs:[] tuplePattern p in
+ parseForRest false pattern startPos p
+ | _ ->
+ parseForRest true pat startPos p
+ end
+ end
+ | _ ->
+ Parser.leaveBreadcrumb p Grammar.Pattern;
+ let pat = parsePattern p in
+ Parser.eatBreadcrumb p;
+ parseForRest false pat startPos p
+ in
+ Parser.eatBreadcrumb p;
+ Parser.endRegion p;
+ forExpr
+
+
+and parseWhileExpression p =
+ let startPos = p.Parser.startPos in
+ Parser.expect While p;
+ let expr1 = parseExpr ~context:WhenExpr p in
+ Parser.expect Lbrace p;
+ let expr2 = parseExprBlock p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.while_ ~loc expr1 expr2
+
+and parsePatternGuard p =
+ match p.Parser.token with
+ | When | If ->
+ Parser.next p;
+ Some (parseExpr ~context:WhenExpr p)
+ | _ ->
+ None
+
+and parsePatternMatchCase p =
+ Parser.beginRegion p;
+ Parser.leaveBreadcrumb p Grammar.PatternMatchCase;
+ match p.Parser.token with
+ | Token.Bar ->
+ Parser.next p;
+ Parser.leaveBreadcrumb p Grammar.Pattern;
+ let lhs = parsePattern p in
+ Parser.eatBreadcrumb p;
+ let guard = parsePatternGuard p in
+ let () = match p.token with
+ | EqualGreater -> Parser.next p
+ | _ -> Recover.recoverEqualGreater p
+ in
+ let rhs = parseExprBlock p in
+ Parser.endRegion p;
+ Parser.eatBreadcrumb p;
+ Some (Ast_helper.Exp.case lhs ?guard rhs)
+ | _ ->
+ Parser.endRegion p;
+ Parser.eatBreadcrumb p;
+ None
+
+and parsePatternMatching p =
+ let cases =
+ parseDelimitedRegion
+ ~grammar:Grammar.PatternMatching
+ ~closing:Rbrace
+ ~f:parsePatternMatchCase
+ p
+ in
+ let () = match cases with
+ | [] -> Parser.err ~startPos:p.prevEndPos p (
+ Diagnostics.message "Pattern matching needs at least one case"
+ )
+ | _ -> ()
+ in
+ cases
+
+and parseSwitchExpression p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Switch p;
+ let switchExpr = parseExpr ~context:WhenExpr p in
+ Parser.expect Lbrace p;
+ let cases = parsePatternMatching p in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.match_ ~loc switchExpr cases
+
+(*
+ * argument ::=
+ * | _ (* syntax sugar *)
+ * | expr
+ * | expr : type
+ * | ~ label-name
+ * | ~ label-name
+ * | ~ label-name ?
+ * | ~ label-name = expr
+ * | ~ label-name = _ (* syntax sugar *)
+ * | ~ label-name = expr : type
+ * | ~ label-name = ? expr
+ * | ~ label-name = ? _ (* syntax sugar *)
+ * | ~ label-name = ? expr : type
+ *
+ * uncurried_argument ::=
+ * | . argument
+ *)
+and parseArgument p =
+ if (
+ p.Parser.token = Token.Tilde ||
+ p.token = Dot ||
+ p.token = Underscore ||
+ Grammar.isExprStart p.token
+ ) then (
+ match p.Parser.token with
+ | Dot ->
+ let uncurried = true in
+ Parser.next(p);
+ begin match p.token with
+ (* apply(.) *)
+ | Rparen ->
+ let unitExpr = Ast_helper.Exp.construct
+ (Location.mknoloc (Longident.Lident "()"))
+ None
+ in
+ Some (uncurried, Asttypes.Nolabel, unitExpr)
+ | _ ->
+ parseArgument2 p ~uncurried
+ end
+ | _ ->
+ parseArgument2 p ~uncurried:false
+ ) else
+ None
+
+and parseArgument2 p ~uncurried =
+ match p.Parser.token with
+ (* foo(_), do not confuse with foo(_ => x), TODO: performance *)
+ | Underscore when not (isEs6ArrowExpression ~inTernary:false p) ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ let exp = Ast_helper.Exp.ident ~loc (
+ Location.mkloc (Longident.Lident "_") loc
+ ) in
+ Some (uncurried, Asttypes.Nolabel, exp)
+ | Tilde ->
+ Parser.next p;
+ (* TODO: nesting of pattern matches not intuitive for error recovery *)
+ begin match p.Parser.token with
+ | Lident ident ->
+ let startPos = p.startPos in
+ Parser.next p;
+ let endPos = p.prevEndPos in
+ let loc = mkLoc startPos endPos in
+ let propLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in
+ let identExpr = Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc (
+ Location.mkloc (Longident.Lident ident) loc
+ ) in
+ begin match p.Parser.token with
+ | Question ->
+ Parser.next p;
+ Some (uncurried, Asttypes.Optional ident, identExpr)
+ | Equal ->
+ Parser.next p;
+ let label = match p.Parser.token with
+ | Question ->
+ Parser.next p;
+ Asttypes.Optional ident
+ | _ ->
+ Labelled ident
+ in
+ let expr = match p.Parser.token with
+ | Underscore when not (isEs6ArrowExpression ~inTernary:false p) ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Ast_helper.Exp.ident ~loc (
+ Location.mkloc (Longident.Lident "_") loc
+ )
+ | _ ->
+ let expr = parseConstrainedOrCoercedExpr p in
+ {expr with pexp_attributes = propLocAttr::expr.pexp_attributes}
+ in
+ Some (uncurried, label, expr)
+ | Colon ->
+ Parser.next p;
+ let typ = parseTypExpr p in
+ let loc = mkLoc startPos p.prevEndPos in
+ let expr = Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ in
+ Some (uncurried, Labelled ident, expr)
+ | _ ->
+ Some (uncurried, Labelled ident, identExpr)
+ end
+ | t ->
+ Parser.err p (Diagnostics.lident t);
+ Some (uncurried, Nolabel, Recover.defaultExpr ())
+ end
+ | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p)
+
+and parseCallExpr p funExpr =
+ Parser.expect Lparen p;
+ let startPos = p.Parser.startPos in
+ Parser.leaveBreadcrumb p Grammar.ExprCall;
+ let args =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.ArgumentList
+ ~closing:Rparen
+ ~f:parseArgument p
+ in
+ Parser.expect Rparen p;
+ let args = match args with
+ | [] ->
+ let loc = mkLoc startPos p.prevEndPos in
+ (* No args -> unit sugar: `foo()` *)
+ [ false,
+ Asttypes.Nolabel,
+ Ast_helper.Exp.construct
+ ~loc (Location.mkloc (Longident.Lident "()") loc) None
+ ]
+ | [
+ true,
+ Asttypes.Nolabel,
+ ({
+ pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None);
+ pexp_loc = loc;
+ pexp_attributes = []
+ } as expr)
+ ] when (not loc.loc_ghost) && p.mode = ParseForTypeChecker ->
+ (* Since there is no syntax space for arity zero vs arity one,
+ * we expand
+ * `fn(. ())` into
+ * `fn(. {let __res_unit = (); __res_unit})`
+ * when the parsetree is intended for type checking
+ *
+ * Note:
+ * `fn(.)` is treated as zero arity application.
+ * The invisible unit expression here has loc_ghost === true
+ *
+ * Related: https://github.com/rescript-lang/syntax/issues/138
+ *)
+ [
+ true,
+ Asttypes.Nolabel,
+ Ast_helper.Exp.let_
+ Asttypes.Nonrecursive
+ [Ast_helper.Vb.mk
+ (Ast_helper.Pat.var (Location.mknoloc "__res_unit"))
+ expr]
+ (Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident "__res_unit")))
+ ]
+ | args -> args
+ in
+ let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in
+ let args = match args with
+ | (u, lbl, expr)::args ->
+ let group (grp, acc) (uncurried, lbl, expr) =
+ let (_u, grp) = grp in
+ if uncurried == true then
+ ((true, [lbl, expr]), ((_u, (List.rev grp))::acc))
+ else
+ ((_u, ((lbl, expr)::grp)), acc)
+ in
+ let ((_u, grp), acc) = List.fold_left group((u, [lbl, expr]), []) args in
+ List.rev ((_u, (List.rev grp))::acc)
+ | [] -> []
+ in
+ let apply = List.fold_left (fun callBody group ->
+ let (uncurried, args) = group in
+ let (args, wrap) = processUnderscoreApplication args in
+ let exp = if uncurried then
+ let attrs = [uncurryAttr] in
+ Ast_helper.Exp.apply ~loc ~attrs callBody args
+ else
+ Ast_helper.Exp.apply ~loc callBody args
+ in
+ wrap exp
+ ) funExpr args
+ in
+ Parser.eatBreadcrumb p;
+ apply
+
+and parseValueOrConstructor p =
+ let startPos = p.Parser.startPos in
+ let rec aux p acc =
+ match p.Parser.token with
+ | Uident ident ->
+ let endPosLident = p.endPos in
+ Parser.next p;
+ begin match p.Parser.token with
+ | Dot ->
+ Parser.next p;
+ aux p (ident::acc)
+ | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum ->
+ let lparen = p.startPos in
+ let args = parseConstructorArgs p in
+ let rparen = p.prevEndPos in
+ let lident = buildLongident (ident::acc) in
+ let tail = match args with
+ | [] -> None
+ | [{Parsetree.pexp_desc = Pexp_tuple _} as arg] as args ->
+ let loc = mkLoc lparen rparen in
+ if p.mode = ParseForTypeChecker then
+ (* Some(1, 2) for type-checker *)
+ Some arg
+ else
+ (* Some((1, 2)) for printer *)
+ Some (Ast_helper.Exp.tuple ~loc args)
+ | [arg] ->
+ Some arg
+ | args ->
+ let loc = mkLoc lparen rparen in
+ Some (Ast_helper.Exp.tuple ~loc args)
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ let identLoc = mkLoc startPos endPosLident in
+ Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail
+ | _ ->
+ let loc = mkLoc startPos p.prevEndPos in
+ let lident = buildLongident (ident::acc) in
+ Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None
+ end
+ | Lident ident ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let lident = buildLongident (ident::acc) in
+ Ast_helper.Exp.ident ~loc (Location.mkloc lident loc)
+ | token ->
+ Parser.next p;
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ Recover.defaultExpr()
+ in
+ aux p []
+
+and parsePolyVariantExpr p =
+ let startPos = p.startPos in
+ let (ident, _loc) = parseHashIdent ~startPos p in
+ begin match p.Parser.token with
+ | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum ->
+ let lparen = p.startPos in
+ let args = parseConstructorArgs p in
+ let rparen = p.prevEndPos in
+ let loc_paren = mkLoc lparen rparen in
+ let tail = match args with
+ | [] -> None
+ | [{Parsetree.pexp_desc = Pexp_tuple _} as expr ] as args ->
+ if p.mode = ParseForTypeChecker then
+ (* #a(1, 2) for type-checker *)
+ Some expr
+ else
+ (* #a((1, 2)) for type-checker *)
+ Some (Ast_helper.Exp.tuple ~loc:loc_paren args)
+ | [arg] -> Some arg
+ | args ->
+ (* #a((1, 2)) for printer *)
+ Some (Ast_helper.Exp.tuple ~loc:loc_paren args)
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.variant ~loc ident tail
+ | _ ->
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.variant ~loc ident None
+ end
+
+and parseConstructorArgs p =
+ let lparen = p.Parser.startPos in
+ Parser.expect Lparen p;
+ let args =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.ExprList ~f:parseConstrainedExprRegion ~closing:Rparen p
+ in
+ Parser.expect Rparen p;
+ match args with
+ | [] ->
+ let loc = mkLoc lparen p.prevEndPos in
+ [Ast_helper.Exp.construct
+ ~loc (Location.mkloc (Longident.Lident "()") loc) None]
+ | args -> args
+
+and parseTupleExpr ~first ~startPos p =
+ let exprs =
+ first::(
+ parseCommaDelimitedRegion
+ p
+ ~grammar:Grammar.ExprList
+ ~closing:Rparen
+ ~f:parseConstrainedExprRegion
+ )
+ in
+ Parser.expect Rparen p;
+ let () = match exprs with
+ | [_] ->
+ Parser.err ~startPos ~endPos:p.prevEndPos p
+ (Diagnostics.message ErrorMessages.tupleSingleElement)
+ | _ -> ()
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Exp.tuple ~loc exprs
+
+and parseSpreadExprRegion p =
+ match p.Parser.token with
+ | DotDotDot ->
+ Parser.next p;
+ let expr = parseConstrainedOrCoercedExpr p in
+ Some (true, expr)
+ | token when Grammar.isExprStart token ->
+ Some (false, parseConstrainedOrCoercedExpr p)
+ | _ -> None
+
+and parseListExpr ~startPos p =
+ let listExprs =
+ parseCommaDelimitedReversedList
+ p ~grammar:Grammar.ListExpr ~closing:Rbrace ~f:parseSpreadExprRegion
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ match listExprs with
+ | (true, expr)::exprs ->
+ let exprs = exprs |> List.map snd |> List.rev in
+ makeListExpression loc exprs (Some expr)
+ | exprs ->
+ let exprs =
+ exprs
+ |> List.map (fun (spread, expr) ->
+ if spread then
+ Parser.err p (Diagnostics.message ErrorMessages.listExprSpread);
+ expr)
+ |> List.rev
+ in
+ makeListExpression loc exprs None
+
+(* Overparse ... and give a nice error message *)
+and parseNonSpreadExp ~msg p =
+ let () = match p.Parser.token with
+ | DotDotDot ->
+ Parser.err p (Diagnostics.message msg);
+ Parser.next p;
+ | _ -> ()
+ in
+ match p.Parser.token with
+ | token when Grammar.isExprStart token ->
+ let expr = parseExpr p in
+ begin match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ let typ = parseTypExpr p in
+ let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in
+ Some (Ast_helper.Exp.constraint_ ~loc expr typ)
+ | _ -> Some expr
+ end
+ | _ -> None
+
+and parseArrayExp p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lbracket p;
+ let exprs =
+ parseCommaDelimitedRegion
+ p
+ ~grammar:Grammar.ExprList
+ ~closing:Rbracket
+ ~f:(parseNonSpreadExp ~msg:ErrorMessages.arrayExprSpread)
+ in
+ Parser.expect Rbracket p;
+ Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) exprs
+
+(* TODO: check attributes in the case of poly type vars,
+ * might be context dependend: parseFieldDeclaration (see ocaml) *)
+and parsePolyTypeExpr p =
+ let startPos = p.Parser.startPos in
+ match p.Parser.token with
+ | SingleQuote ->
+ let vars = parseTypeVarList p in
+ begin match vars with
+ | _v1::_v2::_ ->
+ Parser.expect Dot p;
+ let typ = parseTypExpr p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.poly ~loc vars typ
+ | [var] ->
+ begin match p.Parser.token with
+ | Dot ->
+ Parser.next p;
+ let typ = parseTypExpr p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.poly ~loc vars typ
+ | EqualGreater ->
+ Parser.next p;
+ let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in
+ let returnType = parseTypExpr ~alias:false p in
+ let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in
+ Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType
+ | _ ->
+ Ast_helper.Typ.var ~loc:var.loc var.txt
+ end
+ | _ -> assert false
+ end
+ | _ ->
+ parseTypExpr p
+
+(* 'a 'b 'c *)
+and parseTypeVarList p =
+ let rec loop p vars =
+ match p.Parser.token with
+ | SingleQuote ->
+ Parser.next p;
+ let (lident, loc) = parseLident p in
+ let var = Location.mkloc lident loc in
+ loop p (var::vars)
+ | _ ->
+ List.rev vars
+ in
+ loop p []
+
+and parseLidentList p =
+ let rec loop p ls =
+ match p.Parser.token with
+ | Lident lident ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ loop p ((Location.mkloc lident loc)::ls)
+ | _ ->
+ List.rev ls
+ in
+ loop p []
+
+and parseAtomicTypExpr ~attrs p =
+ Parser.leaveBreadcrumb p Grammar.AtomicTypExpr;
+ let startPos = p.Parser.startPos in
+ let typ = match p.Parser.token with
+ | SingleQuote ->
+ Parser.next p;
+ let (ident, loc) = parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p in
+ Ast_helper.Typ.var ~loc ~attrs ident
+ | Underscore ->
+ let endPos = p.endPos in
+ Parser.next p;
+ Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs ()
+ | Lparen ->
+ Parser.next p;
+ begin match p.Parser.token with
+ | Rparen ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let unitConstr = Location.mkloc (Longident.Lident "unit") loc in
+ Ast_helper.Typ.constr ~attrs unitConstr []
+ | _ ->
+ let t = parseTypExpr p in
+ begin match p.token with
+ | Comma ->
+ Parser.next p;
+ parseTupleType ~attrs ~first:t ~startPos p
+ | _ ->
+ Parser.expect Rparen p;
+ {t with
+ ptyp_loc = mkLoc startPos p.prevEndPos;
+ ptyp_attributes = List.concat [attrs; t.ptyp_attributes]}
+ end
+ end
+ | Lbracket ->
+ parsePolymorphicVariantType ~attrs p
+ | Uident _ | Lident _ ->
+ let constr = parseValuePath p in
+ let args = parseTypeConstructorArgs ~constrName:constr p in
+ Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args
+ | Module ->
+ Parser.next p;
+ Parser.expect Lparen p;
+ let packageType = parsePackageType ~startPos ~attrs p in
+ Parser.expect Rparen p;
+ {packageType with ptyp_loc = mkLoc startPos p.prevEndPos}
+ | Percent ->
+ let extension = parseExtension p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.extension ~attrs ~loc extension
+ | Lbrace ->
+ parseRecordOrObjectType ~attrs p
+ | token ->
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart with
+ | Some () ->
+ parseAtomicTypExpr ~attrs p
+ | None ->
+ Parser.err ~startPos:p.prevEndPos p (Diagnostics.unexpected token p.breadcrumbs);
+ Recover.defaultType()
+ end
+ in
+ Parser.eatBreadcrumb p;
+ typ
+
+(* package-type ::=
+ | modtype-path
+ ∣ modtype-path with package-constraint { and package-constraint }
+ *)
+and parsePackageType ~startPos ~attrs p =
+ let modTypePath = parseModuleLongIdent ~lowercase:true p in
+ begin match p.Parser.token with
+ | Lident "with" ->
+ Parser.next p;
+ let constraints = parsePackageConstraints p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.package ~loc ~attrs modTypePath constraints
+ | _ ->
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.package ~loc ~attrs modTypePath []
+ end
+
+(* package-constraint { and package-constraint } *)
+and parsePackageConstraints p =
+ let first =
+ Parser.expect Typ p;
+ let typeConstr = parseValuePath p in
+ Parser.expect Equal p;
+ let typ = parseTypExpr p in
+ (typeConstr, typ)
+ in
+ let rest = parseRegion
+ ~grammar:Grammar.PackageConstraint
+ ~f:parsePackageConstraint
+ p
+ in
+ first::rest
+
+(* and type typeconstr = typexpr *)
+and parsePackageConstraint p =
+ match p.Parser.token with
+ | And ->
+ Parser.next p;
+ Parser.expect Typ p;
+ let typeConstr = parseValuePath p in
+ Parser.expect Equal p;
+ let typ = parseTypExpr p in
+ Some (typeConstr, typ)
+ | _ -> None
+
+and parseRecordOrObjectType ~attrs p =
+ (* for inline record in constructor *)
+ let startPos = p.Parser.startPos in
+ Parser.expect Lbrace p;
+ let closedFlag = match p.token with
+ | DotDot -> Parser.next p; Asttypes.Open
+ | Dot -> Parser.next p; Asttypes.Closed
+ | _ -> Asttypes.Closed
+ in
+ let () = match p.token with
+ | Lident _ ->
+ Parser.err p (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration)
+ | _ -> ()
+ in
+ let startFirstField = p.startPos in
+ let fields =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ in
+ let () = match fields with
+ | [Parsetree.Oinherit {ptyp_loc}] ->
+ (* {...x}, spread without extra fields *)
+ Parser.err p ~startPos:startFirstField ~endPos:ptyp_loc.loc_end
+ (Diagnostics.message ErrorMessages.sameTypeSpread)
+ | _ -> ()
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.object_ ~loc ~attrs fields closedFlag
+
+(* TODO: check associativity in combination with attributes *)
+and parseTypeAlias p typ =
+ match p.Parser.token with
+ | As ->
+ Parser.next p;
+ Parser.expect SingleQuote p;
+ let (ident, _loc) = parseLident p in
+ (* TODO: how do we parse attributes here? *)
+ Ast_helper.Typ.alias ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) typ ident
+ | _ -> typ
+
+
+(* type_parameter ::=
+ * | type_expr
+ * | ~ident: type_expr
+ * | ~ident: type_expr=?
+ *
+ * note:
+ * | attrs ~ident: type_expr -> attrs are on the arrow
+ * | attrs type_expr -> attrs are here part of the type_expr
+ *
+ * uncurried_type_parameter ::=
+ * | . type_parameter
+ *)
+and parseTypeParameter p =
+ if (
+ p.Parser.token = Token.Tilde ||
+ p.token = Dot ||
+ Grammar.isTypExprStart p.token
+ ) then (
+ let startPos = p.Parser.startPos in
+ let uncurried = Parser.optional p Dot in
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Tilde ->
+ Parser.next p;
+ let (name, loc) = parseLident p in
+ let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in
+ Parser.expect ~grammar:Grammar.TypeExpression Colon p;
+ let typ =
+ let typ = parseTypExpr p in
+ {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes}
+ in
+ begin match p.Parser.token with
+ | Equal ->
+ Parser.next p;
+ Parser.expect Question p;
+ Some (uncurried, attrs, Asttypes.Optional name, typ, startPos)
+ | _ ->
+ Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)
+ end
+ | Lident _ ->
+ let (name, loc) = parseLident p in
+ begin match p.token with
+ | Colon ->
+ let () =
+ let error = Diagnostics.message (
+ ErrorMessages.missingTildeLabeledParameter name
+ ) in
+ Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error
+ in
+ Parser.next p;
+ let typ = parseTypExpr p in
+ begin match p.Parser.token with
+ | Equal ->
+ Parser.next p;
+ Parser.expect Question p;
+ Some (uncurried, attrs, Asttypes.Optional name, typ, startPos)
+ | _ ->
+ Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos)
+ end
+ | _ ->
+ let constr = Location.mkloc (Longident.Lident name) loc in
+ let args = parseTypeConstructorArgs ~constrName:constr p in
+ let typ = Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args
+ in
+
+ let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in
+ let typ = parseTypeAlias p typ in
+ Some (uncurried, [], Asttypes.Nolabel, typ, startPos)
+ end
+ | _ ->
+ let typ = parseTypExpr p in
+ let typWithAttributes = {typ with ptyp_attributes = List.concat[attrs; typ.ptyp_attributes]} in
+ Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos)
+ ) else
+ None
+
+(* (int, ~x:string, float) *)
+and parseTypeParameters p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lparen p;
+ match p.Parser.token with
+ | Rparen ->
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let unitConstr = Location.mkloc (Longident.Lident "unit") loc in
+ let typ = Ast_helper.Typ.constr unitConstr [] in
+ [(false, [], Asttypes.Nolabel, typ, startPos)]
+ | _ ->
+ let params =
+ parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen ~f:parseTypeParameter p
+ in
+ Parser.expect Rparen p;
+ params
+
+and parseEs6ArrowType ~attrs p =
+ let startPos = p.Parser.startPos in
+ match p.Parser.token with
+ | Tilde ->
+ Parser.next p;
+ let (name, loc) = parseLident p in
+ let lblLocAttr = (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) in
+ Parser.expect ~grammar:Grammar.TypeExpression Colon p;
+ let typ =
+ let typ = parseTypExpr ~alias:false ~es6Arrow:false p in
+ {typ with ptyp_attributes = lblLocAttr::typ.ptyp_attributes}
+ in
+ let arg = match p.Parser.token with
+ | Equal ->
+ Parser.next p;
+ Parser.expect Question p;
+ Asttypes.Optional name
+ | _ ->
+ Asttypes.Labelled name
+ in
+ Parser.expect EqualGreater p;
+ let returnType = parseTypExpr ~alias:false p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType
+ | _ ->
+ let parameters = parseTypeParameters p in
+ Parser.expect EqualGreater p;
+ let returnType = parseTypExpr ~alias:false p in
+ let endPos = p.prevEndPos in
+ let typ = List.fold_right (fun (uncurried, attrs, argLbl, typ, startPos) t ->
+ let attrs = if uncurried then uncurryAttr::attrs else attrs in
+ Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t
+ ) parameters returnType
+ in
+ {typ with
+ ptyp_attributes = List.concat [typ.ptyp_attributes; attrs];
+ ptyp_loc = mkLoc startPos p.prevEndPos}
+
+(*
+ * typexpr ::=
+ * | 'ident
+ * | _
+ * | (typexpr)
+ * | typexpr => typexpr --> es6 arrow
+ * | (typexpr, typexpr) => typexpr --> es6 arrow
+ * | /typexpr, typexpr, typexpr/ --> tuple
+ * | typeconstr
+ * | typeconstr
+ * | typeconstr
+ * | typexpr as 'ident
+ * | %attr-id --> extension
+ * | %attr-id(payload) --> extension
+ *
+ * typeconstr ::=
+ * | lident
+ * | uident.lident
+ * | uident.uident.lident --> long module path
+ *)
+and parseTypExpr ?attrs ?(es6Arrow=true) ?(alias=true) p =
+ (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *)
+ let startPos = p.Parser.startPos in
+ let attrs = match attrs with
+ | Some attrs ->
+ attrs
+ | None ->
+ parseAttributes p in
+ let typ = if es6Arrow && isEs6ArrowType p then
+ parseEs6ArrowType ~attrs p
+ else
+ let typ = parseAtomicTypExpr ~attrs p in
+ parseArrowTypeRest ~es6Arrow ~startPos typ p
+ in
+ let typ = if alias then parseTypeAlias p typ else typ in
+ (* Parser.eatBreadcrumb p; *)
+ typ
+
+and parseArrowTypeRest ~es6Arrow ~startPos typ p =
+ match p.Parser.token with
+ | (EqualGreater | MinusGreater) as token when es6Arrow == true ->
+ (* error recovery *)
+ if token = MinusGreater then (
+ Parser.expect EqualGreater p;
+ );
+ Parser.next p;
+ let returnType = parseTypExpr ~alias:false p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType
+ | _ -> typ
+
+and parseTypExprRegion p =
+ if Grammar.isTypExprStart p.Parser.token then
+ Some (parseTypExpr p)
+ else
+ None
+
+and parseTupleType ~attrs ~first ~startPos p =
+ let typexprs =
+ first::(
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.TypExprList
+ ~closing:Rparen
+ ~f:parseTypExprRegion
+ p
+ )
+ in
+ Parser.expect Rparen p;
+ let () = match typexprs with
+ | [_] ->
+ Parser.err ~startPos ~endPos:p.prevEndPos p
+ (Diagnostics.message ErrorMessages.tupleSingleElement)
+ | _ -> ()
+ in
+ let tupleLoc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc typexprs
+
+and parseTypeConstructorArgRegion p =
+ if Grammar.isTypExprStart p.Parser.token then
+ Some (parseTypExpr p)
+ else if p.token = LessThan then (
+ Parser.next p;
+ parseTypeConstructorArgRegion p
+ ) else
+ None
+
+(* Js.Nullable.value<'a> *)
+and parseTypeConstructorArgs ~constrName p =
+ let opening = p.Parser.token in
+ let openingStartPos = p.startPos in
+ match opening with
+ | LessThan | Lparen ->
+ Scanner.setDiamondMode p.scanner;
+ Parser.next p;
+ let typeArgs =
+ (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *)
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.TypExprList
+ ~closing:GreaterThan
+ ~f:parseTypeConstructorArgRegion
+ p
+ in
+ let () = match p.token with
+ | Rparen when opening = Token.Lparen ->
+ let typ = Ast_helper.Typ.constr constrName typeArgs in
+ let msg =
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.text "Type parameters require angle brackets:";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ ResPrinter.printTypExpr typ CommentTable.empty;
+ ]
+ )
+ ]
+ ) |> Doc.toString ~width:80
+ in
+ Parser.err ~startPos:openingStartPos p (Diagnostics.message msg);
+ Parser.next p
+ | _ ->
+ Parser.expect GreaterThan p
+ in
+ Scanner.popMode p.scanner Diamond;
+ typeArgs
+ | _ -> []
+
+(* string-field-decl ::=
+ * | string: poly-typexpr
+ * | attributes string-field-decl *)
+and parseStringFieldDeclaration p =
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | String name ->
+ let nameStartPos = p.startPos in
+ let nameEndPos = p.endPos in
+ Parser.next p;
+ let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in
+ Parser.expect ~grammar:Grammar.TypeExpression Colon p;
+ let typ = parsePolyTypeExpr p in
+ Some(Parsetree.Otag (fieldName, attrs, typ))
+ | DotDotDot ->
+ Parser.next p;
+ let typ = parseTypExpr p in
+ Some(Parsetree.Oinherit typ)
+ | Lident name ->
+ let nameLoc = mkLoc p.startPos p.endPos in
+ Parser.err p (Diagnostics.message (ErrorMessages.objectQuotedFieldName name));
+ Parser.next p;
+ let fieldName = Location.mkloc name nameLoc in
+ Parser.expect ~grammar:Grammar.TypeExpression Colon p;
+ let typ = parsePolyTypeExpr p in
+ Some(Parsetree.Otag (fieldName, attrs, typ))
+ | _token ->
+ None
+
+(* field-decl ::=
+ * | [mutable] field-name : poly-typexpr
+ * | attributes field-decl *)
+and parseFieldDeclaration p =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributes p in
+ let mut = if Parser.optional p Token.Mutable then
+ Asttypes.Mutable
+ else
+ Asttypes.Immutable
+ in
+ let (lident, loc) = match p.token with
+ | _ -> parseLident p
+ in
+ let name = Location.mkloc lident loc in
+ let typ = match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ parsePolyTypeExpr p
+ | _ ->
+ Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} []
+ in
+ let loc = mkLoc startPos typ.ptyp_loc.loc_end in
+ Ast_helper.Type.field ~attrs ~loc ~mut name typ
+
+
+and parseFieldDeclarationRegion p =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributes p in
+ let mut = if Parser.optional p Token.Mutable then
+ Asttypes.Mutable
+ else
+ Asttypes.Immutable
+ in
+ match p.token with
+ | Lident _ ->
+ let (lident, loc) = parseLident p in
+ let name = Location.mkloc lident loc in
+ let typ = match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ parsePolyTypeExpr p
+ | _ ->
+ Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} []
+ in
+ let loc = mkLoc startPos typ.ptyp_loc.loc_end in
+ Some(Ast_helper.Type.field ~attrs ~loc ~mut name typ)
+ | _ ->
+ None
+
+(* record-decl ::=
+ * | { field-decl }
+ * | { field-decl, field-decl }
+ * | { field-decl, field-decl, field-decl, }
+ *)
+and parseRecordDeclaration p =
+ Parser.leaveBreadcrumb p Grammar.RecordDecl;
+ Parser.expect Lbrace p;
+ let rows =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.RecordDecl
+ ~closing:Rbrace
+ ~f:parseFieldDeclarationRegion
+ p
+ in
+ Parser.expect Rbrace p;
+ Parser.eatBreadcrumb p;
+ rows
+
+(* constr-args ::=
+ * | (typexpr)
+ * | (typexpr, typexpr)
+ * | (typexpr, typexpr, typexpr,)
+ * | (record-decl)
+ *
+ * TODO: should we overparse inline-records in every position?
+ * Give a good error message afterwards?
+ *)
+and parseConstrDeclArgs p =
+ let constrArgs = match p.Parser.token with
+ | Lparen ->
+ Parser.next p;
+ (* TODO: this could use some cleanup/stratification *)
+ begin match p.Parser.token with
+ | Lbrace ->
+ let lbrace = p.startPos in
+ Parser.next p;
+ let startPos = p.Parser.startPos in
+ begin match p.Parser.token with
+ | DotDot | Dot ->
+ let closedFlag = match p.token with
+ | DotDot -> Parser.next p; Asttypes.Open
+ | Dot -> Parser.next p; Asttypes.Closed
+ | _ -> Asttypes.Closed
+ in
+ let fields =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in
+ Parser.optional p Comma |> ignore;
+ let moreArgs =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.TypExprList
+ ~closing:Rparen
+ ~f:parseTypExprRegion
+ p
+ in
+ Parser.expect Rparen p;
+ Parsetree.Pcstr_tuple (typ::moreArgs)
+ | DotDotDot ->
+ let dotdotdotStart = p.startPos in
+ let dotdotdotEnd = p.endPos in
+ (* start of object type spreading, e.g. `User({...a, "u": int})` *)
+ Parser.next p;
+ let typ = parseTypExpr p in
+ let () = match p.token with
+ | Rbrace ->
+ (* {...x}, spread without extra fields *)
+ Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p
+ (Diagnostics.message ErrorMessages.sameTypeSpread);
+ Parser.next p;
+ | _ -> Parser.expect Comma p
+ in
+ let () = match p.token with
+ | Lident _ ->
+ Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p
+ (Diagnostics.message ErrorMessages.spreadInRecordDeclaration)
+ | _ -> ()
+ in
+ let fields =
+ (Parsetree.Oinherit typ)::(
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ )
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let typ =
+ Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p
+ in
+ let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in
+ Parser.optional p Comma |> ignore;
+ let moreArgs =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.TypExprList
+ ~closing:Rparen
+ ~f:parseTypExprRegion p
+ in
+ Parser.expect Rparen p;
+ Parsetree.Pcstr_tuple (typ::moreArgs)
+ | _ ->
+ let attrs = parseAttributes p in
+ begin match p.Parser.token with
+ | String _ ->
+ let closedFlag = Asttypes.Closed in
+ let fields = match attrs with
+ | [] ->
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ | attrs ->
+ let first =
+ Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations;
+ let field = match parseStringFieldDeclaration p with
+ | Some field -> field
+ | None -> assert false
+ in
+ (* parse comma after first *)
+ let () = match p.Parser.token with
+ | Rbrace | Eof -> ()
+ | Comma -> Parser.next p
+ | _ -> Parser.expect Comma p
+ in
+ Parser.eatBreadcrumb p;
+ begin match field with
+ | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct)
+ | Oinherit ct -> Oinherit ct
+ end
+ in
+ first::(
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ ) in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let typ =
+ Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag
+ |> parseTypeAlias p
+ in
+ let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in
+ Parser.optional p Comma |> ignore;
+ let moreArgs =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.TypExprList
+ ~closing:Rparen
+ ~f:parseTypExprRegion p
+ in
+ Parser.expect Rparen p;
+ Parsetree.Pcstr_tuple (typ::moreArgs)
+ | _ ->
+ let fields = match attrs with
+ | [] ->
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.FieldDeclarations
+ ~closing:Rbrace
+ ~f:parseFieldDeclarationRegion
+ p
+ | attrs ->
+ let first =
+ let field = parseFieldDeclaration p in
+ Parser.expect Comma p;
+ {field with Parsetree.pld_attributes = attrs}
+ in
+ first::(
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.FieldDeclarations
+ ~closing:Rbrace
+ ~f:parseFieldDeclarationRegion
+ p
+ )
+ in
+ let () = match fields with
+ | [] -> Parser.err ~startPos:lbrace p (
+ Diagnostics.message "An inline record declaration needs at least one field"
+ )
+ | _ -> ()
+ in
+ Parser.expect Rbrace p;
+ Parser.optional p Comma |> ignore;
+ Parser.expect Rparen p;
+ Parsetree.Pcstr_record fields
+ end
+ end
+ | _ ->
+ let args =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.TypExprList
+ ~closing:Rparen
+ ~f:parseTypExprRegion
+ p
+ in
+ Parser.expect Rparen p;
+ Parsetree.Pcstr_tuple args
+ end
+ | _ -> Pcstr_tuple []
+ in
+ let res = match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ Some (parseTypExpr p)
+ | _ -> None
+ in
+ (constrArgs, res)
+
+(* constr-decl ::=
+ * | constr-name
+ * | attrs constr-name
+ * | constr-name const-args
+ * | attrs constr-name const-args *)
+ and parseTypeConstructorDeclarationWithBar p =
+ match p.Parser.token with
+ | Bar ->
+ let startPos = p.Parser.startPos in
+ Parser.next p;
+ Some (parseTypeConstructorDeclaration ~startPos p)
+ | _ -> None
+
+ and parseTypeConstructorDeclaration ~startPos p =
+ Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration;
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Uident uident ->
+ let uidentLoc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ let (args, res) = parseConstrDeclArgs p in
+ Parser.eatBreadcrumb p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Type.constructor ~loc ~attrs ?res ~args (Location.mkloc uident uidentLoc)
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Ast_helper.Type.constructor (Location.mknoloc "_")
+
+ (* [|] constr-decl { | constr-decl } *)
+ and parseTypeConstructorDeclarations ?first p =
+ let firstConstrDecl = match first with
+ | None ->
+ let startPos = p.Parser.startPos in
+ ignore (Parser.optional p Token.Bar);
+ parseTypeConstructorDeclaration ~startPos p
+ | Some firstConstrDecl ->
+ firstConstrDecl
+ in
+ firstConstrDecl::(
+ parseRegion
+ ~grammar:Grammar.ConstructorDeclaration
+ ~f:parseTypeConstructorDeclarationWithBar
+ p
+ )
+
+(*
+ * type-representation ::=
+ * ∣ = [ | ] constr-decl { | constr-decl }
+ * ∣ = private [ | ] constr-decl { | constr-decl }
+ * | = |
+ * ∣ = private |
+ * ∣ = record-decl
+ * ∣ = private record-decl
+ * | = ..
+ *)
+and parseTypeRepresentation p =
+ Parser.leaveBreadcrumb p Grammar.TypeRepresentation;
+ (* = consumed *)
+ let privateFlag =
+ if Parser.optional p Token.Private
+ then Asttypes.Private
+ else Asttypes.Public
+ in
+ let kind = match p.Parser.token with
+ | Bar | Uident _ ->
+ Parsetree.Ptype_variant (parseTypeConstructorDeclarations p)
+ | Lbrace ->
+ Parsetree.Ptype_record (parseRecordDeclaration p)
+ | DotDot ->
+ Parser.next p;
+ Ptype_open
+ | token ->
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ (* TODO: I have no idea if this is even remotely a good idea *)
+ Parsetree.Ptype_variant []
+ in
+ Parser.eatBreadcrumb p;
+ (privateFlag, kind)
+
+(* type-param ::=
+ * | variance 'lident
+ * | variance 'uident
+ * | variance _
+ *
+ * variance ::=
+ * | +
+ * | -
+ * | (* empty *)
+ *)
+and parseTypeParam p =
+ let variance = match p.Parser.token with
+ | Plus -> Parser.next p; Asttypes.Covariant
+ | Minus -> Parser.next p; Contravariant
+ | _ -> Invariant
+ in
+ match p.Parser.token with
+ | SingleQuote ->
+ Parser.next p;
+ let (ident, loc) =
+ parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in
+ Some (Ast_helper.Typ.var ~loc ident, variance)
+ | Underscore ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Some (Ast_helper.Typ.any ~loc (), variance)
+ | (Uident _ | Lident _) as token ->
+ Parser.err p (Diagnostics.message (
+ "Type params start with a singlequote: '" ^ (Token.toString token)
+ ));
+ let (ident, loc) =
+ parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p in
+ Some (Ast_helper.Typ.var ~loc ident, variance)
+ | _token ->
+ None
+
+(* type-params ::=
+ * |
+ * ∣
+ * ∣
+ * ∣
+ *
+ * TODO: when we have pretty-printer show an error
+ * with the actual code corrected. *)
+and parseTypeParams ~parent p =
+ let opening = p.Parser.token in
+ match opening with
+ | LessThan | Lparen when p.startPos.pos_lnum == p.prevEndPos.pos_lnum ->
+ Scanner.setDiamondMode p.scanner;
+ let openingStartPos = p.startPos in
+ Parser.leaveBreadcrumb p Grammar.TypeParams;
+ Parser.next p;
+ let params =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.TypeParams
+ ~closing:GreaterThan
+ ~f:parseTypeParam
+ p
+ in
+ let () = match p.token with
+ | Rparen when opening = Token.Lparen ->
+ let msg =
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.text "Type parameters require angle brackets:";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ Doc.concat [
+ ResPrinter.printLongident parent.Location.txt;
+ ResPrinter.printTypeParams params CommentTable.empty;
+ ]
+ ]
+ )
+ ]
+ ) |> Doc.toString ~width:80
+ in
+ Parser.err ~startPos:openingStartPos p (Diagnostics.message msg);
+ Parser.next p
+ | _ ->
+ Parser.expect GreaterThan p
+ in
+ Scanner.popMode p.scanner Diamond;
+ Parser.eatBreadcrumb p;
+ params
+ | _ -> []
+
+(* type-constraint ::= constraint ' ident = typexpr *)
+and parseTypeConstraint p =
+ let startPos = p.Parser.startPos in
+ match p.Parser.token with
+ | Token.Constraint ->
+ Parser.next p;
+ Parser.expect SingleQuote p;
+ begin match p.Parser.token with
+ | Lident ident ->
+ let identLoc = mkLoc startPos p.endPos in
+ Parser.next p;
+ Parser.expect Equal p;
+ let typ = parseTypExpr p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc)
+ | t ->
+ Parser.err p (Diagnostics.lident t);
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Typ.any (), parseTypExpr p, loc)
+ end
+ | _ -> None
+
+(* type-constraints ::=
+ * | (* empty *)
+ * | type-constraint
+ * | type-constraint type-constraint
+ * | type-constraint type-constraint type-constraint (* 0 or more *)
+ *)
+and parseTypeConstraints p =
+ parseRegion
+ ~grammar:Grammar.TypeConstraint
+ ~f:parseTypeConstraint
+ p
+
+and parseTypeEquationOrConstrDecl p =
+ let uidentStartPos = p.Parser.startPos in
+ match p.Parser.token with
+ | Uident uident ->
+ Parser.next p;
+ begin match p.Parser.token with
+ | Dot ->
+ Parser.next p;
+ let typeConstr =
+ parseValuePathTail p uidentStartPos (Longident.Lident uident)
+ in
+ let loc = mkLoc uidentStartPos p.prevEndPos in
+ let typ = parseTypeAlias p (
+ Ast_helper.Typ.constr ~loc typeConstr (parseTypeConstructorArgs ~constrName:typeConstr p)
+ ) in
+ begin match p.token with
+ | Equal ->
+ Parser.next p;
+ let (priv, kind) = parseTypeRepresentation p in
+ (Some typ, priv, kind)
+ | EqualGreater ->
+ Parser.next p;
+ let returnType = parseTypExpr ~alias:false p in
+ let loc = mkLoc uidentStartPos p.prevEndPos in
+ let arrowType = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in
+ let typ = parseTypeAlias p arrowType in
+ (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)
+ | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)
+ end
+ | _ ->
+ let uidentEndPos = p.prevEndPos in
+ let (args, res) = parseConstrDeclArgs p in
+ let first = Some (
+ let uidentLoc = mkLoc uidentStartPos uidentEndPos in
+ Ast_helper.Type.constructor
+ ~loc:(mkLoc uidentStartPos p.prevEndPos)
+ ?res
+ ~args
+ (Location.mkloc uident uidentLoc)
+ ) in
+ (None, Asttypes.Public, Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first))
+ end
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ (* TODO: is this a good idea? *)
+ (None, Asttypes.Public, Parsetree.Ptype_abstract)
+
+and parseRecordOrObjectDecl p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lbrace p;
+ match p.Parser.token with
+ | DotDot | Dot ->
+ let closedFlag = match p.token with
+ | DotDot -> Parser.next p; Asttypes.Open
+ | Dot -> Parser.next p; Asttypes.Closed
+ | _ -> Asttypes.Closed
+ in
+ let fields =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let typ =
+ Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag
+ |> parseTypeAlias p
+ in
+ let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in
+ (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)
+ | DotDotDot ->
+ let dotdotdotStart = p.startPos in
+ let dotdotdotEnd = p.endPos in
+ (* start of object type spreading, e.g. `type u = {...a, "u": int}` *)
+ Parser.next p;
+ let typ = parseTypExpr p in
+ let () = match p.token with
+ | Rbrace ->
+ (* {...x}, spread without extra fields *)
+ Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p
+ (Diagnostics.message ErrorMessages.sameTypeSpread);
+ Parser.next p;
+ | _ -> Parser.expect Comma p
+ in
+ let () = match p.token with
+ | Lident _ ->
+ Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p
+ (Diagnostics.message ErrorMessages.spreadInRecordDeclaration)
+ | _ -> ()
+ in
+ let fields =
+ (Parsetree.Oinherit typ)::(
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ )
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let typ =
+ Ast_helper.Typ.object_ ~loc fields Asttypes.Closed |> parseTypeAlias p
+ in
+ let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in
+ (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)
+ | _ ->
+ let attrs = parseAttributes p in
+ begin match p.Parser.token with
+ | String _ ->
+ let closedFlag = Asttypes.Closed in
+ let fields = match attrs with
+ | [] ->
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ | attrs ->
+ let first =
+ Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations;
+ let field = match parseStringFieldDeclaration p with
+ | Some field -> field
+ | None -> assert false
+ in
+ (* parse comma after first *)
+ let () = match p.Parser.token with
+ | Rbrace | Eof -> ()
+ | Comma -> Parser.next p
+ | _ -> Parser.expect Comma p
+ in
+ Parser.eatBreadcrumb p;
+ begin match field with
+ | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct)
+ | Oinherit ct -> Oinherit ct
+ end
+ in
+ first::(
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.StringFieldDeclarations
+ ~closing:Rbrace
+ ~f:parseStringFieldDeclaration
+ p
+ )
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let typ =
+ Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag |> parseTypeAlias p
+ in
+ let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in
+ (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)
+ | _ ->
+ Parser.leaveBreadcrumb p Grammar.RecordDecl;
+ let fields = match attrs with
+ | [] ->
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.FieldDeclarations
+ ~closing:Rbrace
+ ~f:parseFieldDeclarationRegion
+ p
+ | attr::_ as attrs ->
+ let first =
+ let field = parseFieldDeclaration p in
+ Parser.optional p Comma |> ignore;
+ {field with
+ Parsetree.pld_attributes = attrs;
+ pld_loc = {
+ field.Parsetree.pld_loc with loc_start =
+ (attr |> fst).loc.loc_start
+ }
+ }
+ in
+ first::(
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.FieldDeclarations
+ ~closing:Rbrace
+ ~f:parseFieldDeclarationRegion
+ p
+ )
+ in
+ let () = match fields with
+ | [] -> Parser.err ~startPos p (
+ Diagnostics.message "A record needs at least one field"
+ )
+ | _ -> ()
+ in
+ Parser.expect Rbrace p;
+ Parser.eatBreadcrumb p;
+ (None, Asttypes.Public, Parsetree.Ptype_record fields)
+ end
+
+and parsePrivateEqOrRepr p =
+ Parser.expect Private p;
+ match p.Parser.token with
+ | Lbrace ->
+ let (manifest, _ ,kind) = parseRecordOrObjectDecl p in
+ (manifest, Asttypes.Private, kind)
+ | Uident _ ->
+ let (manifest, _, kind) = parseTypeEquationOrConstrDecl p in
+ (manifest, Asttypes.Private, kind)
+ | Bar | DotDot ->
+ let (_, kind) = parseTypeRepresentation p in
+ (None, Asttypes.Private, kind)
+ | t when Grammar.isTypExprStart t ->
+ (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract)
+ | _ ->
+ let (_, kind) = parseTypeRepresentation p in
+ (None, Asttypes.Private, kind)
+
+(*
+ polymorphic-variant-type ::=
+ | [ tag-spec-first { | tag-spec } ]
+ | [> [ tag-spec ] { | tag-spec } ]
+ | [< [|] tag-spec-full { | tag-spec-full } [ > { `tag-name }+ ] ]
+
+ tag-spec-first ::= `tag-name [ of typexpr ]
+ | [ typexpr ] | tag-spec
+
+ tag-spec ::= `tag-name [ of typexpr ]
+ | typexpr
+
+ tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ]
+ | typexpr
+*)
+and parsePolymorphicVariantType ~attrs p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lbracket p;
+ match p.token with
+ | GreaterThan ->
+ Parser.next p;
+ let rowFields =
+ begin match p.token with
+ | Rbracket ->
+ []
+ | Bar ->
+ parseTagSpecs p
+ | _ ->
+ let rowField = parseTagSpec p in
+ rowField :: parseTagSpecs p
+ end
+ in
+ let variant =
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.variant ~attrs ~loc rowFields Open None in
+ Parser.expect Rbracket p;
+ variant
+ | LessThan ->
+ Parser.next p;
+ Parser.optional p Bar |> ignore;
+ let rowField = parseTagSpecFull p in
+ let rowFields = parseTagSpecFulls p in
+ let tagNames =
+ if p.token == GreaterThan
+ then begin
+ Parser.next p;
+ let rec loop p = match p.Parser.token with
+ | Rbracket -> []
+ | _ ->
+ let (ident, _loc) = parseHashIdent ~startPos:p.startPos p in
+ ident :: loop p
+ in
+ loop p
+ end
+ else [] in
+ let variant =
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed (Some tagNames) in
+ Parser.expect Rbracket p;
+ variant
+ | _ ->
+ let rowFields1 = parseTagSpecFirst p in
+ let rowFields2 = parseTagSpecs p in
+ let variant =
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None in
+ Parser.expect Rbracket p;
+ variant
+
+and parseTagSpecFulls p =
+ match p.Parser.token with
+ | Rbracket ->
+ []
+ | GreaterThan ->
+ []
+ | Bar ->
+ Parser.next p;
+ let rowField = parseTagSpecFull p in
+ rowField ::parseTagSpecFulls p
+ | _ ->
+ []
+
+and parseTagSpecFull p =
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Hash ->
+ parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p
+ | _ ->
+ let typ = parseTypExpr ~attrs p in
+ Parsetree.Rinherit typ
+
+and parseTagSpecs p =
+ match p.Parser.token with
+ | Bar ->
+ Parser.next p;
+ let rowField = parseTagSpec p in
+ rowField :: parseTagSpecs p
+ | _ ->
+ []
+
+and parseTagSpec p =
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Hash ->
+ parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p
+ | _ ->
+ let typ = parseTypExpr ~attrs p in
+ Parsetree.Rinherit typ
+
+and parseTagSpecFirst p =
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Bar ->
+ Parser.next p;
+ [parseTagSpec p]
+ | Hash ->
+ [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p]
+ | _ ->
+ let typ = parseTypExpr ~attrs p in
+ begin match p.token with
+ | Rbracket ->
+ (* example: [ListStyleType.t] *)
+ [Parsetree.Rinherit typ;]
+ | _ ->
+ Parser.expect Bar p;
+ [Parsetree.Rinherit typ; parseTagSpec p]
+ end
+
+and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field =
+ let startPos = p.Parser.startPos in
+ let (ident, loc) = parseHashIdent ~startPos p in
+ let rec loop p =
+ match p.Parser.token with
+ | Band when full ->
+ Parser.next p;
+ let rowField = parsePolymorphicVariantTypeArgs p in
+ rowField :: loop p
+ | _ ->
+ []
+ in
+ let firstTuple, tagContainsAConstantEmptyConstructor =
+ match p.Parser.token with
+ | Band when full ->
+ Parser.next p;
+ [parsePolymorphicVariantTypeArgs p], true
+ | Lparen ->
+ [parsePolymorphicVariantTypeArgs p], false
+ | _ ->
+ [], true
+ in
+ let tuples = firstTuple @ loop p in
+ Parsetree.Rtag (
+ Location.mkloc ident loc,
+ attrs,
+ tagContainsAConstantEmptyConstructor,
+ tuples
+ )
+
+and parsePolymorphicVariantTypeArgs p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lparen p;
+ let args = parseCommaDelimitedRegion
+ ~grammar:Grammar.TypExprList
+ ~closing:Rparen
+ ~f:parseTypExprRegion
+ p
+ in
+ Parser.expect Rparen p;
+ let attrs = [] in
+ let loc = mkLoc startPos p.prevEndPos in
+ match args with
+ | [{ptyp_desc = Ptyp_tuple _} as typ] as types ->
+ if p.mode = ParseForTypeChecker then
+ typ
+ else
+ Ast_helper.Typ.tuple ~loc ~attrs types
+ | [typ] -> typ
+ | types -> Ast_helper.Typ.tuple ~loc ~attrs types
+
+and parseTypeEquationAndRepresentation p =
+ match p.Parser.token with
+ | Equal | Bar as token ->
+ if token = Bar then Parser.expect Equal p;
+ Parser.next p;
+ begin match p.Parser.token with
+ | Uident _ ->
+ parseTypeEquationOrConstrDecl p
+ | Lbrace ->
+ parseRecordOrObjectDecl p
+ | Private ->
+ parsePrivateEqOrRepr p
+ | Bar | DotDot ->
+ let (priv, kind) = parseTypeRepresentation p in
+ (None, priv, kind)
+ | _ ->
+ let manifest = Some (parseTypExpr p) in
+ begin match p.Parser.token with
+ | Equal ->
+ Parser.next p;
+ let (priv, kind) = parseTypeRepresentation p in
+ (manifest, priv, kind)
+ | _ ->
+ (manifest, Public, Parsetree.Ptype_abstract)
+ end
+ end
+ | _ -> (None, Public, Parsetree.Ptype_abstract)
+
+(* type-definition ::= type [rec] typedef { and typedef }
+ * typedef ::= typeconstr-name [type-params] type-information
+ * type-information ::= [type-equation] [type-representation] { type-constraint }
+ * type-equation ::= = typexpr *)
+and parseTypeDef ~attrs ~startPos p =
+ Parser.leaveBreadcrumb p Grammar.TypeDef;
+ (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *)
+ Parser.leaveBreadcrumb p Grammar.TypeConstrName;
+ let (name, loc) = parseLident p in
+ let typeConstrName = Location.mkloc name loc in
+ Parser.eatBreadcrumb p;
+ let params =
+ let constrName = Location.mkloc (Longident.Lident name) loc in
+ parseTypeParams ~parent:constrName p in
+ let typeDef =
+ let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in
+ let cstrs = parseTypeConstraints p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Type.mk
+ ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest typeConstrName
+ in
+ Parser.eatBreadcrumb p;
+ typeDef
+
+and parseTypeExtension ~params ~attrs ~name p =
+ Parser.expect PlusEqual p;
+ let priv =
+ if Parser.optional p Token.Private
+ then Asttypes.Private
+ else Asttypes.Public
+ in
+ let constrStart = p.Parser.startPos in
+ Parser.optional p Bar |> ignore;
+ let first =
+ let (attrs, name, kind) = match p.Parser.token with
+ | Bar ->
+ Parser.next p;
+ parseConstrDef ~parseAttrs:true p
+ | _ ->
+ parseConstrDef ~parseAttrs:true p
+ in
+ let loc = mkLoc constrStart p.prevEndPos in
+ Ast_helper.Te.constructor ~loc ~attrs name kind
+ in
+ let rec loop p cs =
+ match p.Parser.token with
+ | Bar ->
+ let startPos = p.Parser.startPos in
+ Parser.next p;
+ let (attrs, name, kind) = parseConstrDef ~parseAttrs:true p in
+ let extConstr =
+ Ast_helper.Te.constructor ~attrs ~loc:(mkLoc startPos p.prevEndPos) name kind
+ in
+ loop p (extConstr::cs)
+ | _ ->
+ List.rev cs
+ in
+ let constructors = loop p [first] in
+ Ast_helper.Te.mk ~attrs ~params ~priv name constructors
+
+and parseTypeDefinitions ~attrs ~name ~params ~startPos p =
+ let typeDef =
+ let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in
+ let cstrs = parseTypeConstraints p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Type.mk
+ ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest
+ {name with txt = lidentOfPath name.Location.txt}
+ in
+ let rec loop p defs =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributesAndBinding p in
+ match p.Parser.token with
+ | And ->
+ Parser.next p;
+ let attrs = match p.token with
+ | Export ->
+ let exportLoc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in
+ genTypeAttr::attrs
+ | _ -> attrs
+ in
+ let typeDef = parseTypeDef ~attrs ~startPos p in
+ loop p (typeDef::defs)
+ | _ ->
+ List.rev defs
+ in
+ loop p [typeDef]
+
+(* TODO: decide if we really want type extensions (eg. type x += Blue)
+ * It adds quite a bit of complexity that can be avoided,
+ * implemented for now. Needed to get a feel for the complexities of
+ * this territory of the grammar *)
+and parseTypeDefinitionOrExtension ~attrs p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Token.Typ p;
+ let recFlag = match p.token with
+ | Rec -> Parser.next p; Asttypes.Recursive
+ | Lident "nonrec" ->
+ Parser.next p;
+ Asttypes.Nonrecursive
+ | _ -> Asttypes.Nonrecursive
+ in
+ let name = parseValuePath p in
+ let params = parseTypeParams ~parent:name p in
+ match p.Parser.token with
+ | PlusEqual ->
+ TypeExt(parseTypeExtension ~params ~attrs ~name p)
+ | _ ->
+ (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *)
+ let () = match name.Location.txt with
+ | Lident _ -> ()
+ | longident ->
+ Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p
+ (longident |> ErrorMessages.typeDeclarationNameLongident |> Diagnostics.message)
+ in
+ let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in
+ TypeDef {recFlag; types = typeDefs}
+
+(* external value-name : typexp = external-declaration *)
+and parseExternalDef ~attrs ~startPos p =
+ Parser.leaveBreadcrumb p Grammar.External;
+ Parser.expect Token.External p;
+ let (name, loc) = parseLident p in
+ let name = Location.mkloc name loc in
+ Parser.expect ~grammar:(Grammar.TypeExpression) Colon p;
+ let typExpr = parseTypExpr p in
+ let equalStart = p.startPos in
+ let equalEnd = p.endPos in
+ Parser.expect Equal p;
+ let prim = match p.token with
+ | String s -> Parser.next p; [s]
+ | _ ->
+ Parser.err ~startPos:equalStart ~endPos:equalEnd p
+ (Diagnostics.message
+ ("An external requires the name of the JS value you're referring to, like \""
+ ^ name.txt ^ "\"."));
+ []
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in
+ Parser.eatBreadcrumb p;
+ vb
+
+(* constr-def ::=
+ * | constr-decl
+ * | constr-name = constr
+ *
+ * constr-decl ::= constr-name constr-args
+ * constr-name ::= uident
+ * constr ::= path-uident *)
+and parseConstrDef ~parseAttrs p =
+ let attrs = if parseAttrs then parseAttributes p else [] in
+ let name = match p.Parser.token with
+ | Uident name ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Location.mkloc name loc
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Location.mknoloc "_"
+ in
+ let kind = match p.Parser.token with
+ | Lparen ->
+ let (args, res) = parseConstrDeclArgs p in
+ Parsetree.Pext_decl (args, res)
+ | Equal ->
+ Parser.next p;
+ let longident = parseModuleLongIdent ~lowercase:false p in
+ Parsetree.Pext_rebind longident
+ | Colon ->
+ Parser.next p;
+ let typ = parseTypExpr p in
+ Parsetree.Pext_decl (Pcstr_tuple [], Some typ)
+ | _ ->
+ Parsetree.Pext_decl (Pcstr_tuple [], None)
+ in
+ (attrs, name, kind)
+
+(*
+ * exception-definition ::=
+ * | exception constr-decl
+ * ∣ exception constr-name = constr
+ *
+ * constr-name ::= uident
+ * constr ::= long_uident *)
+and parseExceptionDef ~attrs p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Token.Exception p;
+ let (_, name, kind) = parseConstrDef ~parseAttrs:false p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Te.constructor ~loc ~attrs name kind
+
+(* module structure on the file level *)
+and parseImplementation p : Parsetree.structure =
+ parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion
+ [@@progress (Parser.next, Parser.expect, Parser.checkProgress)]
+
+and parseNewlineOrSemicolonStructure p =
+ match p.Parser.token with
+ | Semicolon ->
+ Parser.next p
+ | token when Grammar.isStructureItemStart token ->
+ if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ()
+ else
+ Parser.err
+ ~startPos:p.prevEndPos
+ ~endPos: p.endPos
+ p
+ (Diagnostics.message "consecutive statements on a line must be separated by ';' or a newline")
+ | _ -> ()
+
+and parseStructureItemRegion p =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Open ->
+ let openDescription = parseOpenDescription ~attrs p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Str.open_ ~loc openDescription)
+ | Let ->
+ let (recFlag, letBindings) = parseLetBindings ~attrs p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Str.value ~loc recFlag letBindings)
+ | Typ ->
+ Parser.beginRegion p;
+ begin match parseTypeDefinitionOrExtension ~attrs p with
+ | TypeDef {recFlag; types} ->
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Str.type_ ~loc recFlag types)
+ | TypeExt(ext) ->
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Str.type_extension ~loc ext)
+ end
+ | External ->
+ let externalDef = parseExternalDef ~attrs ~startPos p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Str.primitive ~loc externalDef)
+ | Import ->
+ let importDescr = parseJsImport ~startPos ~attrs p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let structureItem = JsFfi.toParsetree importDescr in
+ Some {structureItem with pstr_loc = loc}
+ | Exception ->
+ let exceptionDef = parseExceptionDef ~attrs p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Str.exception_ ~loc exceptionDef)
+ | Include ->
+ let includeStatement = parseIncludeStatement ~attrs p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Str.include_ ~loc includeStatement)
+ | Export ->
+ let structureItem = parseJsExport ~attrs p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some {structureItem with pstr_loc = loc}
+ | Module ->
+ Parser.beginRegion p;
+ let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some {structureItem with pstr_loc = loc}
+ | AtAt ->
+ let attr = parseStandaloneAttribute p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Str.attribute ~loc attr)
+ | PercentPercent ->
+ let extension = parseExtension ~moduleLanguage:true p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Str.extension ~attrs ~loc extension)
+ | token when Grammar.isExprStart token ->
+ let prevEndPos = p.Parser.endPos in
+ let exp = parseExpr p in
+ parseNewlineOrSemicolonStructure p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.checkProgress ~prevEndPos ~result:(Ast_helper.Str.eval ~loc ~attrs exp) p
+ | _ ->
+ begin match attrs with
+ | (({Asttypes.loc = attrLoc}, _) as attr)::_ ->
+ Parser.err
+ ~startPos:attrLoc.loc_start
+ ~endPos:attrLoc.loc_end
+ p
+ (Diagnostics.message (ErrorMessages.attributeWithoutNode attr));
+ let expr = parseExpr p in
+ Some (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr)
+ | _ ->
+ None
+ end
+
+and parseJsImport ~startPos ~attrs p =
+ Parser.expect Token.Import p;
+ let importSpec = match p.Parser.token with
+ | Token.Lident _ | Token.At ->
+ let decl = match parseJsFfiDeclaration p with
+ | Some decl -> decl
+ | None -> assert false
+ in
+ JsFfi.Default decl
+ | _ -> JsFfi.Spec(parseJsFfiDeclarations p)
+ in
+ let scope = parseJsFfiScope p in
+ let loc = mkLoc startPos p.prevEndPos in
+ JsFfi.importDescr ~attrs ~importSpec ~scope ~loc
+
+and parseJsExport ~attrs p =
+ let exportStart = p.Parser.startPos in
+ Parser.expect Token.Export p;
+ let exportLoc = mkLoc exportStart p.prevEndPos in
+ let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in
+ let attrs = genTypeAttr::attrs in
+ match p.Parser.token with
+ | Typ ->
+ begin match parseTypeDefinitionOrExtension ~attrs p with
+ | TypeDef {recFlag; types} ->
+ Ast_helper.Str.type_ recFlag types
+ | TypeExt(ext) ->
+ Ast_helper.Str.type_extension ext
+ end
+ | (* Let *) _ ->
+ let (recFlag, letBindings) = parseLetBindings ~attrs p in
+ Ast_helper.Str.value recFlag letBindings
+
+and parseSignJsExport ~attrs p =
+ let exportStart = p.Parser.startPos in
+ Parser.expect Token.Export p;
+ let exportLoc = mkLoc exportStart p.prevEndPos in
+ let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in
+ let attrs = genTypeAttr::attrs in
+ match p.Parser.token with
+ | Typ ->
+ begin match parseTypeDefinitionOrExtension ~attrs p with
+ | TypeDef {recFlag; types} ->
+ let loc = mkLoc exportStart p.prevEndPos in
+ Ast_helper.Sig.type_ recFlag types ~loc
+ | TypeExt(ext) ->
+ let loc = mkLoc exportStart p.prevEndPos in
+ Ast_helper.Sig.type_extension ext ~loc
+ end
+ | (* Let *) _ ->
+ let valueDesc = parseSignLetDesc ~attrs p in
+ let loc = mkLoc exportStart p.prevEndPos in
+ Ast_helper.Sig.value valueDesc ~loc
+
+and parseJsFfiScope p =
+ match p.Parser.token with
+ | Token.Lident "from" ->
+ Parser.next p;
+ begin match p.token with
+ | String s -> Parser.next p; JsFfi.Module s
+ | Uident _ | Lident _ ->
+ let value = parseIdentPath p in
+ JsFfi.Scope value
+ | _ -> JsFfi.Global
+ end
+ | _ -> JsFfi.Global
+
+and parseJsFfiDeclarations p =
+ Parser.expect Token.Lbrace p;
+ let decls = parseCommaDelimitedRegion
+ ~grammar:Grammar.JsFfiImport
+ ~closing:Rbrace
+ ~f:parseJsFfiDeclaration
+ p
+ in
+ Parser.expect Rbrace p;
+ decls
+
+and parseJsFfiDeclaration p =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Lident _ ->
+ let (ident, _) = parseLident p in
+ let alias = match p.token with
+ | As ->
+ Parser.next p;
+ let (ident, _) = parseLident p in
+ ident
+ | _ ->
+ ident
+ in
+ Parser.expect Token.Colon p;
+ let typ = parseTypExpr p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (JsFfi.decl ~loc ~alias ~attrs ~name:ident ~typ)
+ | _ -> None
+
+(* include-statement ::= include module-expr *)
+and parseIncludeStatement ~attrs p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Token.Include p;
+ let modExpr = parseModuleExpr p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Incl.mk ~loc ~attrs modExpr
+
+and parseAtomicModuleExpr p =
+ let startPos = p.Parser.startPos in
+ match p.Parser.token with
+ | Uident _ident ->
+ let longident = parseModuleLongIdent ~lowercase:false p in
+ Ast_helper.Mod.ident ~loc:longident.loc longident
+ | Lbrace ->
+ Parser.next p;
+ let structure = Ast_helper.Mod.structure (
+ parseDelimitedRegion
+ ~grammar:Grammar.Structure
+ ~closing:Rbrace
+ ~f:parseStructureItemRegion
+ p
+ ) in
+ Parser.expect Rbrace p;
+ let endPos = p.prevEndPos in
+ {structure with pmod_loc = mkLoc startPos endPos}
+ | Lparen ->
+ Parser.next p;
+ let modExpr = match p.token with
+ | Rparen ->
+ Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) []
+ | _ ->
+ parseConstrainedModExpr p
+ in
+ Parser.expect Rparen p;
+ modExpr
+ | Lident "unpack" -> (* TODO: should this be made a keyword?? *)
+ Parser.next p;
+ Parser.expect Lparen p;
+ let expr = parseExpr p in
+ begin match p.Parser.token with
+ | Colon ->
+ let colonStart = p.Parser.startPos in
+ Parser.next p;
+ let attrs = parseAttributes p in
+ let packageType = parsePackageType ~startPos:colonStart ~attrs p in
+ Parser.expect Rparen p;
+ let loc = mkLoc startPos p.prevEndPos in
+ let constraintExpr = Ast_helper.Exp.constraint_
+ ~loc
+ expr packageType
+ in
+ Ast_helper.Mod.unpack ~loc constraintExpr
+ | _ ->
+ Parser.expect Rparen p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Mod.unpack ~loc expr
+ end
+ | Percent ->
+ let extension = parseExtension p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Mod.extension ~loc extension
+ | token ->
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ Recover.defaultModuleExpr()
+
+and parsePrimaryModExpr p =
+ let startPos = p.Parser.startPos in
+ let modExpr = parseAtomicModuleExpr p in
+ let rec loop p modExpr =
+ match p.Parser.token with
+ | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum ->
+ loop p (parseModuleApplication p modExpr)
+ | _ -> modExpr
+ in
+ let modExpr = loop p modExpr in
+ {modExpr with pmod_loc = mkLoc startPos p.prevEndPos}
+
+(*
+ * functor-arg ::=
+ * | uident : modtype
+ * | _ : modtype
+ * | modtype --> "punning" for _ : modtype
+ * | attributes functor-arg
+ *)
+and parseFunctorArg p =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Uident ident ->
+ Parser.next p;
+ let uidentEndPos = p.prevEndPos in
+ begin match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ let moduleType = parseModuleType p in
+ let loc = mkLoc startPos uidentEndPos in
+ let argName = Location.mkloc ident loc in
+ Some (attrs, argName, Some moduleType, startPos)
+ | Dot ->
+ Parser.next p;
+ let moduleType =
+ let moduleLongIdent =
+ parseModuleLongIdentTail ~lowercase:false p startPos (Longident.Lident ident) in
+ Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent
+ in
+ let argName = Location.mknoloc "_" in
+ Some (attrs, argName, Some moduleType, startPos)
+ | _ ->
+ let loc = mkLoc startPos uidentEndPos in
+ let modIdent = Location.mkloc (Longident.Lident ident) loc in
+ let moduleType = Ast_helper.Mty.ident ~loc modIdent in
+ let argName = Location.mknoloc "_" in
+ Some (attrs, argName, Some moduleType, startPos)
+ end
+ | Underscore ->
+ Parser.next p;
+ let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in
+ Parser.expect Colon p;
+ let moduleType = parseModuleType p in
+ Some (attrs, argName, Some moduleType, startPos)
+ | Lparen ->
+ Parser.next p;
+ Parser.expect Rparen p;
+ let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in
+ Some (attrs, argName, None, startPos)
+ | _ ->
+ None
+
+and parseFunctorArgs p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lparen p;
+ let args =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.FunctorArgs
+ ~closing:Rparen
+ ~f:parseFunctorArg
+ p
+ in
+ Parser.expect Rparen p;
+ match args with
+ | [] ->
+ [[], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos]
+ | args -> args
+
+and parseFunctorModuleExpr p =
+ let startPos = p.Parser.startPos in
+ let args = parseFunctorArgs p in
+ let returnType = match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ Some (parseModuleType ~es6Arrow:false p)
+ | _ -> None
+ in
+ Parser.expect EqualGreater p;
+ let rhsModuleExpr =
+ let modExpr = parseModuleExpr p in
+ match returnType with
+ | Some modType ->
+ Ast_helper.Mod.constraint_
+ ~loc:(mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end)
+ modExpr modType
+ | None -> modExpr
+ in
+ let endPos = p.prevEndPos in
+ let modExpr = List.fold_right (fun (attrs, name, moduleType, startPos) acc ->
+ Ast_helper.Mod.functor_
+ ~loc:(mkLoc startPos endPos)
+ ~attrs
+ name moduleType acc
+ ) args rhsModuleExpr
+ in
+ {modExpr with pmod_loc = mkLoc startPos endPos}
+
+(* module-expr ::=
+ * | module-path
+ * ∣ { structure-items }
+ * ∣ functorArgs => module-expr
+ * ∣ module-expr(module-expr)
+ * ∣ ( module-expr )
+ * ∣ ( module-expr : module-type )
+ * | extension
+ * | attributes module-expr *)
+and parseModuleExpr p =
+ let attrs = parseAttributes p in
+ let modExpr = if isEs6ArrowFunctor p then
+ parseFunctorModuleExpr p
+ else
+ parsePrimaryModExpr p
+ in
+ {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]}
+
+and parseConstrainedModExpr p =
+ let modExpr = parseModuleExpr p in
+ match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ let modType = parseModuleType p in
+ let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in
+ Ast_helper.Mod.constraint_ ~loc modExpr modType
+ | _ -> modExpr
+
+and parseConstrainedModExprRegion p =
+ if Grammar.isModExprStart p.Parser.token then
+ Some (parseConstrainedModExpr p)
+ else
+ None
+
+and parseModuleApplication p modExpr =
+ let startPos = p.Parser.startPos in
+ Parser.expect Lparen p;
+ let args =
+ parseCommaDelimitedRegion
+ ~grammar:Grammar.ModExprList
+ ~closing:Rparen
+ ~f:parseConstrainedModExprRegion
+ p
+ in
+ Parser.expect Rparen p;
+ let args = match args with
+ | [] ->
+ let loc = mkLoc startPos p.prevEndPos in
+ [Ast_helper.Mod.structure ~loc []]
+ | args -> args
+ in
+ List.fold_left (fun modExpr arg ->
+ Ast_helper.Mod.apply
+ ~loc:(mkLoc modExpr.Parsetree.pmod_loc.loc_start arg.Parsetree.pmod_loc.loc_end)
+ modExpr arg
+ ) modExpr args
+
+and parseModuleOrModuleTypeImplOrPackExpr ~attrs p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Module p;
+ match p.Parser.token with
+ | Typ -> parseModuleTypeImpl ~attrs startPos p
+ | Lparen ->
+ let expr = parseFirstClassModuleExpr ~startPos p in
+ let a = parsePrimaryExpr ~operand:expr p in
+ let expr = parseBinaryExpr ~a p 1 in
+ let expr = parseTernaryExpr expr p in
+ Ast_helper.Str.eval ~attrs expr
+ | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p
+
+and parseModuleTypeImpl ~attrs startPos p =
+ Parser.expect Typ p;
+ let nameStart = p.Parser.startPos in
+ let name = match p.Parser.token with
+ | Lident ident ->
+ Parser.next p;
+ let loc = mkLoc nameStart p.prevEndPos in
+ Location.mkloc ident loc
+ | Uident ident ->
+ Parser.next p;
+ let loc = mkLoc nameStart p.prevEndPos in
+ Location.mkloc ident loc
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Location.mknoloc "_"
+ in
+ Parser.expect Equal p;
+ let moduleType = parseModuleType p in
+ let moduleTypeDeclaration =
+ Ast_helper.Mtd.mk
+ ~attrs
+ ~loc:(mkLoc nameStart p.prevEndPos)
+ ~typ:moduleType
+ name
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Str.modtype ~loc moduleTypeDeclaration
+
+(* definition ::=
+ ∣ module rec module-name : module-type = module-expr { and module-name
+ : module-type = module-expr } *)
+and parseMaybeRecModuleBinding ~attrs ~startPos p =
+ match p.Parser.token with
+ | Token.Rec ->
+ Parser.next p;
+ Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p)
+ | _ ->
+ Ast_helper.Str.module_ (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p)
+
+and parseModuleBinding ~attrs ~startPos p =
+ let name = match p.Parser.token with
+ | Uident ident ->
+ let startPos = p.Parser.startPos in
+ Parser.next p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Location.mkloc ident loc
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Location.mknoloc "_"
+ in
+ let body = parseModuleBindingBody p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Mb.mk ~attrs ~loc name body
+
+and parseModuleBindingBody p =
+ (* TODO: make required with good error message when rec module binding *)
+ let returnModType = match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ Some (parseModuleType p)
+ | _ -> None
+ in
+ Parser.expect Equal p;
+ let modExpr = parseModuleExpr p in
+ match returnModType with
+ | Some modType ->
+ Ast_helper.Mod.constraint_
+ ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end)
+ modExpr modType
+ | None -> modExpr
+
+
+(* module-name : module-type = module-expr
+ * { and module-name : module-type = module-expr } *)
+and parseModuleBindings ~attrs ~startPos p =
+ let rec loop p acc =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributesAndBinding p in
+ match p.Parser.token with
+ | And ->
+ Parser.next p;
+ ignore(Parser.optional p Module); (* over-parse for fault-tolerance *)
+ let modBinding = parseModuleBinding ~attrs ~startPos p in
+ loop p (modBinding::acc)
+ | _ -> List.rev acc
+ in
+ let first = parseModuleBinding ~attrs ~startPos p in
+ loop p [first]
+
+and parseAtomicModuleType p =
+ let startPos = p.Parser.startPos in
+ let moduleType = match p.Parser.token with
+ | Uident _ | Lident _ ->
+ (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... }
+ * lets go with uppercase terminal for now *)
+ let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in
+ Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent
+ | Lparen ->
+ Parser.next p;
+ let mty = parseModuleType p in
+ Parser.expect Rparen p;
+ {mty with pmty_loc = mkLoc startPos p.prevEndPos}
+ | Lbrace ->
+ Parser.next p;
+ let spec =
+ parseDelimitedRegion
+ ~grammar:Grammar.Signature
+ ~closing:Rbrace
+ ~f:parseSignatureItemRegion
+ p
+ in
+ Parser.expect Rbrace p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Mty.signature ~loc spec
+ | Module -> (* TODO: check if this is still atomic when implementing first class modules*)
+ parseModuleTypeOf p
+ | Percent ->
+ let extension = parseExtension p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Mty.extension ~loc extension
+ | token ->
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ Recover.defaultModuleType()
+ in
+ let moduleTypeLoc = mkLoc startPos p.prevEndPos in
+ {moduleType with pmty_loc = moduleTypeLoc}
+
+and parseFunctorModuleType p =
+ let startPos = p.Parser.startPos in
+ let args = parseFunctorArgs p in
+ Parser.expect EqualGreater p;
+ let rhs = parseModuleType p in
+ let endPos = p.prevEndPos in
+ let modType = List.fold_right (fun (attrs, name, moduleType, startPos) acc ->
+ Ast_helper.Mty.functor_
+ ~loc:(mkLoc startPos endPos)
+ ~attrs
+ name moduleType acc
+ ) args rhs
+ in
+ {modType with pmty_loc = mkLoc startPos endPos}
+
+(* Module types are the module-level equivalent of type expressions: they
+ * specify the general shape and type properties of modules.
+ *
+ * module-type ::=
+ * | modtype-path
+ * | { signature }
+ * | ( module-type ) --> parenthesized module-type
+ * | functor-args => module-type --> functor
+ * | module-type => module-type --> functor
+ * | module type of module-expr
+ * | attributes module-type
+ * | module-type with-mod-constraints
+ * | extension
+ *)
+ and parseModuleType ?(es6Arrow=true) ?(with_=true) p =
+ let attrs = parseAttributes p in
+ let modty = if es6Arrow && isEs6ArrowFunctor p then
+ parseFunctorModuleType p
+ else
+ let modty = parseAtomicModuleType p in
+ match p.Parser.token with
+ | EqualGreater when es6Arrow == true ->
+ Parser.next p;
+ let rhs = parseModuleType ~with_:false p in
+ let str = Location.mknoloc "_" in
+ let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in
+ Ast_helper.Mty.functor_ ~loc str (Some modty) rhs
+ | _ -> modty
+ in
+ let moduleType = { modty with
+ pmty_attributes = List.concat [modty.pmty_attributes; attrs]
+ } in
+ if with_ then
+ parseWithConstraints moduleType p
+ else moduleType
+
+
+and parseWithConstraints moduleType p =
+ match p.Parser.token with
+ | Lident "with" ->
+ Parser.next p;
+ let first = parseWithConstraint p in
+ let rec loop p acc =
+ match p.Parser.token with
+ | And ->
+ Parser.next p;
+ loop p ((parseWithConstraint p)::acc)
+ | _ ->
+ List.rev acc
+ in
+ let constraints = loop p [first] in
+ let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in
+ Ast_helper.Mty.with_ ~loc moduleType constraints
+ | _ ->
+ moduleType
+
+(* mod-constraint ::=
+ * | type typeconstr type-equation type-constraints?
+ * ∣ type typeconstr-name := typexpr
+ * ∣ module module-path = extended-module-path
+ * ∣ module module-path := extended-module-path
+ *
+ * TODO: split this up into multiple functions, better errors *)
+and parseWithConstraint p =
+ match p.Parser.token with
+ | Module ->
+ Parser.next p;
+ let modulePath = parseModuleLongIdent ~lowercase:false p in
+ begin match p.Parser.token with
+ | ColonEqual ->
+ Parser.next p;
+ let lident = parseModuleLongIdent ~lowercase:false p in
+ Parsetree.Pwith_modsubst (modulePath, lident)
+ | Equal ->
+ Parser.next p;
+ let lident = parseModuleLongIdent ~lowercase:false p in
+ Parsetree.Pwith_module (modulePath, lident)
+ | token ->
+ (* TODO: revisit *)
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ let lident = parseModuleLongIdent ~lowercase:false p in
+ Parsetree.Pwith_modsubst (modulePath, lident)
+ end
+ | Typ ->
+ Parser.next p;
+ let typeConstr = parseValuePath p in
+ let params = parseTypeParams ~parent:typeConstr p in
+ begin match p.Parser.token with
+ | ColonEqual ->
+ Parser.next p;
+ let typExpr = parseTypExpr p in
+ Parsetree.Pwith_typesubst (
+ typeConstr,
+ Ast_helper.Type.mk
+ ~loc:typeConstr.loc
+ ~params
+ ~manifest:typExpr
+ (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc)
+ )
+ | Equal ->
+ Parser.next p;
+ let typExpr = parseTypExpr p in
+ let typeConstraints = parseTypeConstraints p in
+ Parsetree.Pwith_type (
+ typeConstr,
+ Ast_helper.Type.mk
+ ~loc:typeConstr.loc
+ ~params
+ ~manifest:typExpr
+ ~cstrs:typeConstraints
+ (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc)
+ )
+ | token ->
+ (* TODO: revisit *)
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ let typExpr = parseTypExpr p in
+ let typeConstraints = parseTypeConstraints p in
+ Parsetree.Pwith_type (
+ typeConstr,
+ Ast_helper.Type.mk
+ ~loc:typeConstr.loc
+ ~params
+ ~manifest:typExpr
+ ~cstrs:typeConstraints
+ (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc)
+ )
+ end
+ | token ->
+ (* TODO: implement recovery strategy *)
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ Parsetree.Pwith_type (
+ (Location.mknoloc (Longident.Lident "")),
+ Ast_helper.Type.mk
+ ~params:[]
+ ~manifest:(Recover.defaultType ())
+ ~cstrs:[]
+ (Location.mknoloc "")
+ )
+
+and parseModuleTypeOf p =
+ let startPos = p.Parser.startPos in
+ Parser.expect Module p;
+ Parser.expect Typ p;
+ Parser.expect Of p;
+ let moduleExpr = parseModuleExpr p in
+ Ast_helper.Mty.typeof_ ~loc:(mkLoc startPos p.prevEndPos) moduleExpr
+
+(* module signature on the file level *)
+and parseSpecification p =
+ parseRegion ~grammar:Grammar.Specification ~f:parseSignatureItemRegion p
+ [@@progress (Parser.next, Parser.expect, Parser.checkProgress)]
+
+and parseNewlineOrSemicolonSignature p =
+ match p.Parser.token with
+ | Semicolon ->
+ Parser.next p
+ | token when Grammar.isSignatureItemStart token ->
+ if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ()
+ else
+ Parser.err
+ ~startPos:p.prevEndPos
+ ~endPos: p.endPos
+ p
+ (Diagnostics.message "consecutive specifications on a line must be separated by ';' or a newline")
+ | _ -> ()
+
+and parseSignatureItemRegion p =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributes p in
+ match p.Parser.token with
+ | Let ->
+ Parser.beginRegion p;
+ let valueDesc = parseSignLetDesc ~attrs p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Sig.value ~loc valueDesc)
+ | Typ ->
+ Parser.beginRegion p;
+ begin match parseTypeDefinitionOrExtension ~attrs p with
+ | TypeDef {recFlag; types} ->
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Sig.type_ ~loc recFlag types)
+ | TypeExt(ext) ->
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Sig.type_extension ~loc ext)
+ end
+ | External ->
+ let externalDef = parseExternalDef ~attrs ~startPos p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Sig.value ~loc externalDef)
+ | Export ->
+ let signatureItem = parseSignJsExport ~attrs p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some {signatureItem with psig_loc = loc}
+ | Exception ->
+ let exceptionDef = parseExceptionDef ~attrs p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Sig.exception_ ~loc exceptionDef)
+ | Open ->
+ let openDescription = parseOpenDescription ~attrs p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Sig.open_ ~loc openDescription)
+ | Include ->
+ Parser.next p;
+ let moduleType = parseModuleType p in
+ let includeDescription = Ast_helper.Incl.mk
+ ~loc:(mkLoc startPos p.prevEndPos)
+ ~attrs
+ moduleType
+ in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Sig.include_ ~loc includeDescription)
+ | Module ->
+ Parser.beginRegion p;
+ Parser.next p;
+ begin match p.Parser.token with
+ | Uident _ ->
+ let modDecl = parseModuleDeclarationOrAlias ~attrs p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Sig.module_ ~loc modDecl)
+ | Rec ->
+ let recModule = parseRecModuleSpec ~attrs ~startPos p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Sig.rec_module ~loc recModule)
+ | Typ ->
+ let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in
+ Parser.endRegion p;
+ Some modTypeDecl
+ | _t ->
+ let modDecl = parseModuleDeclarationOrAlias ~attrs p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Parser.endRegion p;
+ Some (Ast_helper.Sig.module_ ~loc modDecl)
+ end
+ | AtAt ->
+ let attr = parseStandaloneAttribute p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Sig.attribute ~loc attr)
+ | PercentPercent ->
+ let extension = parseExtension ~moduleLanguage:true p in
+ parseNewlineOrSemicolonSignature p;
+ let loc = mkLoc startPos p.prevEndPos in
+ Some (Ast_helper.Sig.extension ~attrs ~loc extension)
+ | Import ->
+ Parser.next p;
+ parseSignatureItemRegion p
+ | _ ->
+ begin match attrs with
+ | (({Asttypes.loc = attrLoc}, _) as attr)::_ ->
+ Parser.err
+ ~startPos:attrLoc.loc_start
+ ~endPos:attrLoc.loc_end
+ p
+ (Diagnostics.message (ErrorMessages.attributeWithoutNode attr));
+ Some Recover.defaultSignatureItem
+ | _ ->
+ None
+ end
+
+(* module rec module-name : module-type { and module-name: module-type } *)
+and parseRecModuleSpec ~attrs ~startPos p =
+ Parser.expect Rec p;
+ let rec loop p spec =
+ let startPos = p.Parser.startPos in
+ let attrs = parseAttributesAndBinding p in
+ match p.Parser.token with
+ | And ->
+ (* TODO: give a good error message when with constraint, no parens
+ * and ASet: (Set.S with type elt = A.t)
+ * and BTree: (Btree.S with type elt = A.t)
+ * Without parens, the `and` signals the start of another
+ * `with-constraint`
+ *)
+ Parser.expect And p;
+ let decl = parseRecModuleDeclaration ~attrs ~startPos p in
+ loop p (decl::spec)
+ | _ ->
+ List.rev spec
+ in
+ let first = parseRecModuleDeclaration ~attrs ~startPos p in
+ loop p [first]
+
+(* module-name : module-type *)
+and parseRecModuleDeclaration ~attrs ~startPos p =
+ let name = match p.Parser.token with
+ | Uident modName ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Location.mkloc modName loc
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Location.mknoloc "_"
+ in
+ Parser.expect Colon p;
+ let modType = parseModuleType p in
+ Ast_helper.Md.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs name modType
+
+and parseModuleDeclarationOrAlias ~attrs p =
+ let startPos = p.Parser.startPos in
+ let moduleName = match p.Parser.token with
+ | Uident ident ->
+ let loc = mkLoc p.Parser.startPos p.endPos in
+ Parser.next p;
+ Location.mkloc ident loc
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Location.mknoloc "_"
+ in
+ let body = match p.Parser.token with
+ | Colon ->
+ Parser.next p;
+ parseModuleType p
+ | Equal ->
+ Parser.next p;
+ let lident = parseModuleLongIdent ~lowercase:false p in
+ Ast_helper.Mty.alias lident
+ | token ->
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ Recover.defaultModuleType()
+ in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Md.mk ~loc ~attrs moduleName body
+
+and parseModuleTypeDeclaration ~attrs ~startPos p =
+ Parser.expect Typ p;
+ let moduleName = match p.Parser.token with
+ | Uident ident ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Location.mkloc ident loc
+ | Lident ident ->
+ let loc = mkLoc p.startPos p.endPos in
+ Parser.next p;
+ Location.mkloc ident loc
+ | t ->
+ Parser.err p (Diagnostics.uident t);
+ Location.mknoloc "_"
+ in
+ let typ = match p.Parser.token with
+ | Equal ->
+ Parser.next p;
+ Some (parseModuleType p)
+ | _ -> None
+ in
+ let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in
+ Ast_helper.Sig.modtype ~loc:(mkLoc startPos p.prevEndPos) moduleDecl
+
+and parseSignLetDesc ~attrs p =
+ let startPos = p.Parser.startPos in
+ Parser.optional p Let |> ignore;
+ let (name, loc) = parseLident p in
+ let name = Location.mkloc name loc in
+ Parser.expect Colon p;
+ let typExpr = parsePolyTypeExpr p in
+ let loc = mkLoc startPos p.prevEndPos in
+ Ast_helper.Val.mk ~loc ~attrs name typExpr
+
+(* attr-id ::= lowercase-ident
+∣ capitalized-ident
+∣ attr-id . attr-id *)
+and parseAttributeId ~startPos p =
+ let rec loop p acc =
+ match p.Parser.token with
+ | Lident ident | Uident ident ->
+ Parser.next p;
+ let id = acc ^ ident in
+ begin match p.Parser.token with
+ | Dot -> Parser.next p; loop p (id ^ ".")
+ | _ -> id
+ end
+ | token when Token.isKeyword token ->
+ Parser.next p;
+ let id = acc ^ (Token.toString token) in
+ begin match p.Parser.token with
+ | Dot -> Parser.next p; loop p (id ^ ".")
+ | _ -> id
+ end
+ | token ->
+ Parser.err p (Diagnostics.unexpected token p.breadcrumbs);
+ acc
+ in
+ let id = loop p "" in
+ let endPos = p.prevEndPos in
+ Location.mkloc id (mkLoc startPos endPos)
+
+(*
+ * payload ::= empty
+ * | ( structure-item )
+ *
+ * TODO: what about multiple structure items?
+ * @attr({let x = 1; let x = 2})
+ *
+ * Also what about type-expressions and specifications?
+ * @attr(:myType) ???
+ *)
+and parsePayload p =
+ match p.Parser.token with
+ | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum ->
+ Parser.leaveBreadcrumb p Grammar.AttributePayload;
+ Parser.next p;
+ begin match p.token with
+ | Colon ->
+ Parser.next p;
+ let payload = if Grammar.isSignatureItemStart p.token then
+ Parsetree.PSig (
+ parseDelimitedRegion
+ ~grammar:Grammar.Signature
+ ~closing:Rparen
+ ~f:parseSignatureItemRegion
+ p
+ )
+ else
+ Parsetree.PTyp (parseTypExpr p)
+ in
+ Parser.expect Rparen p;
+ Parser.eatBreadcrumb p;
+ payload
+ | Question ->
+ Parser.next p;
+ let pattern = parsePattern p in
+ let expr = match p.token with
+ | When | If ->
+ Parser.next p;
+ Some (parseExpr p)
+ | _ ->
+ None
+ in
+ Parser.expect Rparen p;
+ Parser.eatBreadcrumb p;
+ Parsetree.PPat (pattern, expr)
+ | _ ->
+ let items = parseDelimitedRegion
+ ~grammar:Grammar.Structure
+ ~closing:Rparen
+ ~f:parseStructureItemRegion
+ p
+ in
+ Parser.expect Rparen p;
+ Parser.eatBreadcrumb p;
+ Parsetree.PStr items
+ end
+ | _ -> Parsetree.PStr []
+
+(* type attribute = string loc * payload *)
+and parseAttribute p =
+ match p.Parser.token with
+ | At ->
+ let startPos = p.startPos in
+ Parser.next p;
+ let attrId = parseAttributeId ~startPos p in
+ let payload = parsePayload p in
+ Some(attrId, payload)
+ | _ -> None
+
+and parseAttributes p =
+ parseRegion p
+ ~grammar:Grammar.Attribute
+ ~f:parseAttribute
+
+(*
+ * standalone-attribute ::=
+ * | @@ atribute-id
+ * | @@ attribute-id ( structure-item )
+ *)
+and parseStandaloneAttribute p =
+ let startPos = p.startPos in
+ Parser.expect AtAt p;
+ let attrId = parseAttributeId ~startPos p in
+ let payload = parsePayload p in
+ (attrId, payload)
+
+(* extension ::= % attr-id attr-payload
+ * | %% attr-id(
+ * expr ::= ...
+ * ∣ extension
+ *
+ * typexpr ::= ...
+ * ∣ extension
+ *
+ * pattern ::= ...
+ * ∣ extension
+ *
+ * module-expr ::= ...
+ * ∣ extension
+ *
+ * module-type ::= ...
+ * ∣ extension
+ *
+ * class-expr ::= ...
+ * ∣ extension
+ *
+ * class-type ::= ...
+ * ∣ extension
+ *
+ *
+ * item extension nodes usable in structures and signature
+ *
+ * item-extension ::= %% attr-id
+ * | %% attr-id(structure-item)
+ *
+ * attr-payload ::= structure-item
+ *
+ * ~moduleLanguage represents whether we're on the module level or not
+ *)
+and parseExtension ?(moduleLanguage=false) p =
+ let startPos = p.Parser.startPos in
+ if moduleLanguage then
+ Parser.expect PercentPercent p
+ else
+ Parser.expect Percent p;
+ let attrId = parseAttributeId ~startPos p in
+ let payload = parsePayload p in
+ (attrId, payload)
diff --git a/jscomp/napkin/res_core.mli b/jscomp/napkin/res_core.mli
new file mode 100644
index 0000000000..760881cd6d
--- /dev/null
+++ b/jscomp/napkin/res_core.mli
@@ -0,0 +1,4 @@
+val parseImplementation:
+ Res_parser.t -> Parsetree.structure
+val parseSpecification:
+ Res_parser.t -> Parsetree.signature
diff --git a/jscomp/napkin/res_diagnostics.ml b/jscomp/napkin/res_diagnostics.ml
new file mode 100644
index 0000000000..843d3e428c
--- /dev/null
+++ b/jscomp/napkin/res_diagnostics.ml
@@ -0,0 +1,182 @@
+module Grammar = Res_grammar
+module Token = Res_token
+
+type category =
+ | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list}
+ | Expected of {context: Grammar.t option; pos: Lexing.position (* prev token end*); token: Token.t}
+ | Message of string
+ | Uident of Token.t
+ | Lident of Token.t
+ | UnclosedString
+ | UnclosedTemplate
+ | UnclosedComment
+ | UnknownUchar of Char.t
+
+type t = {
+ startPos: Lexing.position;
+ endPos: Lexing.position;
+ category: category;
+}
+
+type report = t list
+
+let getStartPos t = t.startPos
+let getEndPos t = t.endPos
+
+let defaultUnexpected token =
+ "I'm not sure what to parse here when looking at \"" ^ (Token.toString token) ^ "\"."
+
+let reservedKeyword token =
+ let tokenTxt = Token.toString token in
+ "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt ^ "\""
+
+let explain t =
+ match t.category with
+ | Uident currentToken ->
+ begin match currentToken with
+ | Lident lident ->
+ let guess = String.capitalize_ascii lident in
+ "Did you mean `" ^ guess ^"` instead of `" ^ lident ^ "`?"
+ | t when Token.isKeyword t ->
+ let token = Token.toString t in
+ "`" ^ token ^ "` is a reserved keyword."
+ | _ ->
+ "At this point, I'm looking for an uppercased name like `Belt` or `Array`"
+ end
+ | Lident currentToken ->
+ begin match currentToken with
+ | Uident uident ->
+ let guess = String.uncapitalize_ascii uident in
+ "Did you mean `" ^ guess ^"` instead of `" ^ uident ^ "`?"
+ | t when Token.isKeyword t ->
+ let token = Token.toString t in
+ "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token ^ "\""
+ | Underscore ->
+ "`_` isn't a valid name."
+ | _ ->
+ "I'm expecting a lowercase name like `user or `age`"
+ end
+ | Message txt -> txt
+ | UnclosedString ->
+ "This string is missing a double quote at the end"
+ | UnclosedTemplate ->
+ "Did you forget to close this template expression with a backtick?"
+ | UnclosedComment ->
+ "This comment seems to be missing a closing `*/`"
+ | UnknownUchar uchar ->
+ begin match uchar with
+ | '^' ->
+ "Not sure what to do with this character.\n" ^
+ " If you're trying to dereference a mutable value, use `myValue.contents` instead.\n" ^
+ " To concatenate strings, use `\"a\" ++ \"b\"` instead."
+ | _ ->
+ "Not sure what to do with this character."
+ end
+ | Expected {context; token = t} ->
+ let hint = match context with
+ | Some grammar -> " It signals the start of " ^ (Grammar.toString grammar)
+ | None -> ""
+ in
+ "Did you forget a `" ^ (Token.toString t) ^ "` here?" ^ hint
+ | Unexpected {token = t; context = breadcrumbs} ->
+ let name = (Token.toString t) in
+ begin match breadcrumbs with
+ | (AtomicTypExpr, _)::breadcrumbs ->
+ begin match breadcrumbs, t with
+ | ((StringFieldDeclarations | FieldDeclarations) , _) :: _, (String _ | At | Rbrace | Comma | Eof) ->
+ "I'm missing a type here"
+ | _, t when Grammar.isStructureItemStart t || t = Eof ->
+ "Missing a type here"
+ | _ ->
+ defaultUnexpected t
+ end
+ | (ExprOperand, _)::breadcrumbs ->
+ begin match breadcrumbs, t with
+ | (ExprBlock, _) :: _, Rbrace ->
+ "It seems that this expression block is empty"
+ | (ExprBlock, _) :: _, Bar -> (* Pattern matching *)
+ "Looks like there might be an expression missing here"
+ | (ExprSetField, _) :: _, _ ->
+ "It seems that this record field mutation misses an expression"
+ | (ExprArrayMutation, _) :: _, _ ->
+ "Seems that an expression is missing, with what do I mutate the array?"
+ | ((ExprBinaryAfterOp _ | ExprUnary), _) ::_, _ ->
+ "Did you forget to write an expression here?"
+ | (Grammar.LetBinding, _)::_, _ ->
+ "This let-binding misses an expression"
+ | _::_, (Rbracket | Rbrace | Eof) ->
+ "Missing expression"
+ | _ ->
+ "I'm not sure what to parse here when looking at \"" ^ name ^ "\"."
+ end
+ | (TypeParam, _)::_ ->
+ begin match t with
+ | Lident ident ->
+ "Did you mean '" ^ ident ^"? A Type parameter starts with a quote."
+ | _ ->
+ "I'm not sure what to parse here when looking at \"" ^ name ^ "\"."
+ end
+ | (Pattern, _)::breadcrumbs ->
+ begin match t, breadcrumbs with
+ | (Equal, (LetBinding,_)::_) ->
+ "I was expecting a name for this let-binding. Example: `let message = \"hello\"`"
+ | (In, (ExprFor,_)::_) ->
+ "A for-loop has the following form: `for i in 0 to 10`. Did you forget to supply a name before `in`?"
+ | (EqualGreater, (PatternMatchCase,_)::_) ->
+ "I was expecting a pattern to match on before the `=>`"
+ | (token, _) when Token.isKeyword t ->
+ reservedKeyword token
+ | (token, _) ->
+ defaultUnexpected token
+ end
+ | _ ->
+ (* TODO: match on circumstance to verify Lident needed ? *)
+ if Token.isKeyword t then
+ "`" ^ name ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ (Token.toString t) ^ "\""
+ else
+ "I'm not sure what to parse here when looking at \"" ^ name ^ "\"."
+ end
+
+let make ~startPos ~endPos category = {
+ startPos;
+ endPos;
+ category
+}
+
+let printReport diagnostics src =
+ let rec print diagnostics src =
+ match diagnostics with
+ | [] -> ()
+ | d::rest ->
+ Res_diagnostics_printing_utils.Super_location.super_error_reporter
+ Format.err_formatter
+ src
+ Location.{
+ loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false};
+ msg = explain d;
+ sub = [];
+ if_highlight = "";
+ };
+ begin match rest with
+ | [] -> ()
+ | _ -> Format.fprintf Format.err_formatter "@."
+ end;
+ print rest src
+ in
+ Format.fprintf Format.err_formatter "@[";
+ print (List.rev diagnostics) src;
+ Format.fprintf Format.err_formatter "@]@."
+
+let unexpected token context =
+ Unexpected {token; context}
+
+let expected ?grammar pos token =
+ Expected {context = grammar; pos; token}
+
+let uident currentToken = Uident currentToken
+let lident currentToken = Lident currentToken
+let unclosedString = UnclosedString
+let unclosedComment = UnclosedComment
+let unclosedTemplate = UnclosedTemplate
+let unknownUchar code = UnknownUchar code
+let message txt = Message txt
diff --git a/jscomp/napkin/res_diagnostics.mli b/jscomp/napkin/res_diagnostics.mli
new file mode 100644
index 0000000000..7855a984f7
--- /dev/null
+++ b/jscomp/napkin/res_diagnostics.mli
@@ -0,0 +1,29 @@
+module Token = Res_token
+module Grammar = Res_grammar
+
+type t
+type category
+type report
+
+val getStartPos: t -> Lexing.position [@@live] (* for playground *)
+val getEndPos: t -> Lexing.position [@@live] (* for playground *)
+
+val explain: t -> string [@@live] (* for playground *)
+
+val unexpected: Token.t -> (Grammar.t * Lexing.position) list -> category
+val expected: ?grammar:Grammar.t -> Lexing.position -> Token.t -> category
+val uident: Token.t -> category
+val lident: Token.t -> category
+val unclosedString: category
+val unclosedTemplate: category
+val unclosedComment: category
+val unknownUchar: Char.t -> category
+val message: string -> category
+
+val make:
+ startPos: Lexing.position
+ -> endPos: Lexing.position
+ -> category
+ -> t
+
+val printReport: t list -> string -> unit
diff --git a/jscomp/napkin/res_diagnostics_printing_utils.ml b/jscomp/napkin/res_diagnostics_printing_utils.ml
new file mode 100644
index 0000000000..758478a434
--- /dev/null
+++ b/jscomp/napkin/res_diagnostics_printing_utils.ml
@@ -0,0 +1,373 @@
+(*
+ This file is taken from ReScript's super_code_frame.ml and super_location.ml
+ We're copying the look of ReScript's terminal error reporting.
+ See https://github.com/rescript-lang/syntax/pull/77 for the rationale.
+ A few lines have been commented out and swapped for their tweaked version.
+*)
+
+(* ===== super_code_frame.ml *)
+
+module Super_code_frame = struct
+
+let digits_count n =
+ let rec loop n base count =
+ if n >= base then loop n (base * 10) (count + 1) else count
+ in
+ loop (abs n) 1 0
+
+let seek_2_lines_before src pos =
+ let open Lexing in
+ let original_line = pos.pos_lnum in
+ let rec loop current_line current_char =
+ if current_line + 2 >= original_line then
+ (current_char, current_line)
+ else
+ loop
+ (if (src.[current_char] [@doesNotRaise]) = '\n' then current_line + 1 else current_line)
+ (current_char + 1)
+ in
+ loop 1 0
+
+let seek_2_lines_after src pos =
+ let open Lexing in
+ let original_line = pos.pos_lnum in
+ let rec loop current_line current_char =
+ if current_char = String.length src then
+ (current_char, current_line)
+ else
+ match src.[current_char] [@doesNotRaise] with
+ | '\n' when current_line = original_line + 2 ->
+ (current_char, current_line)
+ | '\n' -> loop (current_line + 1) (current_char + 1)
+ | _ -> loop current_line (current_char + 1)
+ in
+ loop original_line pos.pos_cnum
+
+let leading_space_count str =
+ let rec loop i count =
+ if i = String.length str then count
+ else if str.[i] [@doesNotRaise] != ' ' then count
+ else loop (i + 1) (count + 1)
+ in
+ loop 0 0
+
+let break_long_line max_width line =
+ let rec loop pos accum =
+ if pos = String.length line then accum
+ else
+ let chunk_length = min max_width (String.length line - pos) in
+ let chunk = (String.sub [@doesNotRaise]) line pos chunk_length in
+ loop (pos + chunk_length) (chunk::accum)
+ in
+ loop 0 [] |> List.rev
+
+let filter_mapi f l =
+ let rec loop f l i accum =
+ match l with
+ | [] -> accum
+ | head::rest ->
+ let accum =
+ match f i head with
+ | None -> accum
+ | Some result -> result::accum
+ in
+ loop f rest (i + 1) accum
+ in
+ loop f l 0 [] |> List.rev
+
+(* Spiritual equivalent of
+ https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601
+*)
+module Color = struct
+ type color =
+ | Dim
+ (* | Filename *)
+ | Err
+ | Warn
+ | NoColor
+
+ let dim = "\x1b[2m"
+ (* let filename = "\x1b[46m" *)
+ let err = "\x1b[1;31m"
+ let warn = "\x1b[1;33m"
+ let reset = "\x1b[0m"
+
+ external isatty : out_channel -> bool = "caml_sys_isatty"
+ (* reasonable heuristic on whether colors should be enabled *)
+ let should_enable_color () =
+ let term = try Sys.getenv "TERM" with Not_found -> "" in
+ term <> "dumb"
+ && term <> ""
+ && isatty stderr
+
+ let color_enabled = ref true
+
+ let setup =
+ let first = ref true in (* initialize only once *)
+ fun o ->
+ if !first then (
+ first := false;
+ color_enabled := (match o with
+ | Some Misc.Color.Always -> true
+ | Some Auto -> should_enable_color ()
+ | Some Never -> false
+ | None -> should_enable_color ())
+ );
+ ()
+end
+
+let setup = Color.setup
+
+type gutter = Number of int | Elided
+type highlighted_string = {s: string; start: int; end_: int}
+type line = {
+ gutter: gutter;
+ content: highlighted_string list;
+}
+(*
+ Features:
+ - display a line gutter
+ - break long line into multiple for terminal display
+ - peek 2 lines before & after for context
+ - center snippet when it's heavily indented
+ - ellide intermediate lines when the reported range is huge
+*)
+let print ~is_warning ~src ~startPos ~endPos =
+ let open Lexing in
+
+ let indent = 2 in
+ let highlight_line_start_line = startPos.pos_lnum in
+ let highlight_line_end_line = endPos.pos_lnum in
+ let (start_line_line_offset, first_shown_line) = seek_2_lines_before src startPos in
+ let (end_line_line_end_offset, last_shown_line) = seek_2_lines_after src endPos in
+
+ let more_than_5_highlighted_lines =
+ highlight_line_end_line - highlight_line_start_line + 1 > 5
+ in
+ let max_line_digits_count = digits_count last_shown_line in
+ (* TODO: change this back to a fixed 100? *)
+ (* 3 for separator + the 2 spaces around it *)
+ let line_width = 78 - max_line_digits_count - indent - 3 in
+ let lines =
+ (String.sub [@doesNotRaise]) src start_line_line_offset (end_line_line_end_offset - start_line_line_offset)
+ |> String.split_on_char '\n'
+ |> filter_mapi (fun i line ->
+ let line_number = i + first_shown_line in
+ if more_than_5_highlighted_lines then
+ if line_number = highlight_line_start_line + 2 then
+ Some (Elided, line)
+ else if line_number > highlight_line_start_line + 2 && line_number < highlight_line_end_line - 1 then None
+ else Some (Number line_number, line)
+ else Some (Number line_number, line)
+ )
+ in
+ let leading_space_to_cut = lines |> List.fold_left (fun current_max (_, line) ->
+ let leading_spaces = leading_space_count line in
+ if String.length line = leading_spaces then
+ (* the line's nothing but spaces. Doesn't count *)
+ current_max
+ else
+ min leading_spaces current_max
+ ) 99999
+ in
+ let separator = if leading_space_to_cut = 0 then "│" else "┆" in
+ let stripped_lines = lines |> List.map (fun (gutter, line) ->
+ let new_content =
+ if String.length line <= leading_space_to_cut then
+ [{s = ""; start = 0; end_ = 0}]
+ else
+ (String.sub [@doesNotRaise]) line leading_space_to_cut (String.length line - leading_space_to_cut)
+ |> break_long_line line_width
+ |> List.mapi (fun i line ->
+ match gutter with
+ | Elided -> {s = line; start = 0; end_ = 0}
+ | Number line_number ->
+ let highlight_line_start_offset = startPos.pos_cnum - startPos.pos_bol in
+ let highlight_line_end_offset = endPos.pos_cnum - endPos.pos_bol in
+ let start =
+ if i = 0 && line_number = highlight_line_start_line then
+ highlight_line_start_offset - leading_space_to_cut
+ else 0
+ in
+ let end_ =
+ if line_number < highlight_line_start_line then 0
+ else if line_number = highlight_line_start_line && line_number = highlight_line_end_line then
+ highlight_line_end_offset - leading_space_to_cut
+ else if line_number = highlight_line_start_line then
+ String.length line
+ else if line_number > highlight_line_start_line && line_number < highlight_line_end_line then
+ String.length line
+ else if line_number = highlight_line_end_line then highlight_line_end_offset - leading_space_to_cut
+ else 0
+ in
+ {s = line; start; end_}
+ )
+ in
+ {gutter; content = new_content}
+ )
+ in
+ let buf = Buffer.create 100 in
+ let open Color in
+ let add_ch =
+ let last_color = ref NoColor in
+ fun color ch ->
+ if not !Color.color_enabled || !last_color = color then
+ Buffer.add_char buf ch
+ else begin
+ let ansi = match !last_color, color with
+ | NoColor, Dim -> dim
+ (* | NoColor, Filename -> filename *)
+ | NoColor, Err -> err
+ | NoColor, Warn -> warn
+ | _, NoColor -> reset
+ | _, Dim -> reset ^ dim
+ (* | _, Filename -> reset ^ filename *)
+ | _, Err -> reset ^ err
+ | _, Warn -> reset ^ warn
+ in
+ Buffer.add_string buf ansi;
+ Buffer.add_char buf ch;
+ last_color := color;
+ end
+ in
+ let draw_gutter color s =
+ for _i = 1 to (max_line_digits_count + indent - String.length s) do
+ add_ch NoColor ' '
+ done;
+ s |> String.iter (add_ch color);
+ add_ch NoColor ' ';
+ separator |> String.iter (add_ch Dim);
+ add_ch NoColor ' ';
+ in
+ stripped_lines |> List.iter (fun {gutter; content} ->
+ match gutter with
+ | Elided ->
+ draw_gutter Dim ".";
+ add_ch Dim '.';
+ add_ch Dim '.';
+ add_ch Dim '.';
+ add_ch NoColor '\n';
+ | Number line_number -> begin
+ content |> List.iteri (fun i line ->
+ let gutter_content = if i = 0 then string_of_int line_number else "" in
+ let gutter_color =
+ if i = 0
+ && line_number >= highlight_line_start_line
+ && line_number <= highlight_line_end_line then
+ if is_warning then Warn else Err
+ else NoColor
+ in
+ draw_gutter gutter_color gutter_content;
+
+ line.s |> String.iteri (fun ii ch ->
+ let c =
+ if ii >= line.start && ii < line.end_ then
+ if is_warning then Warn else Err
+ else NoColor in
+ add_ch c ch;
+ );
+ add_ch NoColor '\n';
+ );
+ end
+ );
+ Buffer.contents buf
+end
+
+
+(* ===== super_location.ml *)
+module Super_location = struct
+
+let fprintf = Format.fprintf
+
+let setup_colors () =
+ Misc.Color.setup !Clflags.color;
+ Super_code_frame.setup !Clflags.color
+
+let print_filename = Location.print_filename
+
+let print_loc ~normalizedRange ppf (loc : Location.t) =
+ setup_colors ();
+ let dim_loc ppf = function
+ | None -> ()
+ | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) ->
+ if start_line = end_line then
+ if start_line_start_char = end_line_end_char then
+ fprintf ppf ":@{%i:%i@}" start_line start_line_start_char
+ else
+ fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char end_line_end_char
+ else
+ fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char end_line end_line_end_char
+ in
+ fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname dim_loc normalizedRange
+;;
+
+
+(* let print ~message_kind intro ppf (loc : Location.t) = *)
+let print ~message_kind intro src ppf (loc : Location.t) =
+ begin match message_kind with
+ | `warning -> fprintf ppf "@[@{%s@}@]@," intro
+ | `warning_as_error -> fprintf ppf "@[@{%s@} (configured as error) @]@," intro
+ | `error -> fprintf ppf "@[@{%s@}@]@," intro
+ end;
+ (* ocaml's reported line/col numbering is horrible and super error-prone
+ when being handled programmatically (or humanly for that matter. If you're
+ an ocaml contributor reading this: who the heck reads the character count
+ starting from the first erroring character?) *)
+ (* let (file, start_line, start_char) = Location.get_pos_info loc.loc_start in *)
+ let (_file, start_line, start_char) = Location.get_pos_info loc.loc_start in
+ let (_, end_line, end_char) = Location.get_pos_info loc.loc_end in
+ (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *)
+ (* start_char is inclusive, end_char is exclusive *)
+ let normalizedRange =
+ (* TODO: lots of the handlings here aren't needed anymore because the new
+ rescript syntax has much stronger invariants regarding positions, e.g.
+ no -1 *)
+ if start_char == -1 || end_char == -1 then
+ (* happens sometimes. Syntax error for example *)
+ None
+ else if start_line = end_line && start_char >= end_char then
+ (* in some errors, starting char and ending char can be the same. But
+ since ending char was supposed to be exclusive, here it might end up
+ smaller than the starting char if we naively did start_char + 1 to
+ just the starting char and forget ending char *)
+ let same_char = start_char + 1 in
+ Some ((start_line, same_char), (end_line, same_char))
+ else
+ (* again: end_char is exclusive, so +1-1=0 *)
+ Some ((start_line, start_char + 1), (end_line, end_char))
+ in
+ fprintf ppf " @[%a@]@," (print_loc ~normalizedRange) loc;
+ match normalizedRange with
+ | None -> ()
+ | Some _ -> begin
+ try
+ (* let src = Ext_io.load_file file in *)
+ (* we're putting the line break `@,` here rather than above, because this
+ branch might not be reached (aka no inline file content display) so
+ we don't wanna end up with two line breaks in the the consequent *)
+ fprintf ppf "@,%s"
+ (Super_code_frame.print
+ ~is_warning:(message_kind=`warning)
+ ~src
+ ~startPos:loc.loc_start
+ ~endPos:loc.loc_end
+ )
+ with
+ (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders.
+ we've already printed the location above, so nothing more to do here. *)
+ | Sys_error _ -> ()
+ end
+;;
+
+(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *)
+(* This is the error report entry point. We'll replace the default reporter with this one. *)
+(* let rec super_error_reporter ppf ({loc; msg; sub} : Location.error) = *)
+let super_error_reporter ppf src ({loc; msg} : Location.error) =
+ setup_colors ();
+ (* open a vertical box. Everything in our message is indented 2 spaces *)
+ (* Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "We've found a bug for you!") src loc msg; *)
+ Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~message_kind:`error "Syntax error!" src) loc msg;
+ (* List.iter (Format.fprintf ppf "@,@[%a@]" super_error_reporter) sub *)
+(* no need to flush here; location's report_exception (which uses this ultimately) flushes *)
+
+end
diff --git a/jscomp/napkin/res_doc.ml b/jscomp/napkin/res_doc.ml
new file mode 100644
index 0000000000..63a9a731c9
--- /dev/null
+++ b/jscomp/napkin/res_doc.ml
@@ -0,0 +1,356 @@
+module MiniBuffer = Res_minibuffer
+
+type mode = Break | Flat
+
+type lineStyle =
+ | Classic (* fits? -> replace with space *)
+ | Soft (* fits? -> replaced with nothing *)
+ | Hard (* always included, forces breaks in parents *)
+ (* always included, forces breaks in parents, but doesn't increase indentation
+ use case: template literals, multiline string content *)
+ | Literal
+
+type t =
+ | Nil
+ | Text of string
+ | Concat of t list
+ | Indent of t
+ | IfBreaks of {yes: t; no: t; mutable broken: bool} (* when broken is true, treat as the yes branch *)
+ | LineSuffix of t
+ | LineBreak of lineStyle
+ | Group of {mutable shouldBreak: bool; doc: t}
+ | CustomLayout of t list
+ | BreakParent
+
+let nil = Nil
+let line = LineBreak Classic
+let hardLine = LineBreak Hard
+let softLine = LineBreak Soft
+let literalLine = LineBreak Literal
+let text s = Text s
+
+(* Optimization. We eagerly collapse and reduce whatever allocation we can *)
+let rec _concat acc l =
+ match l with
+ | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest
+ | Nil :: rest -> _concat acc rest
+ | Concat l2 :: rest -> _concat (_concat acc rest) l2 (* notice the order here *)
+ | x :: rest ->
+ let rest1 = _concat acc rest in
+ if rest1 == rest then l else x :: rest1
+ | [] -> acc
+
+let concat l = Concat(_concat [] l)
+
+let indent d = Indent d
+let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false}
+let lineSuffix d = LineSuffix d
+let group d = Group {shouldBreak = false; doc = d}
+let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d}
+let customLayout gs = CustomLayout gs
+let breakParent = BreakParent
+
+let 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 comma nil
+let doubleQuote = Text "\""
+
+let propagateForcedBreaks doc =
+ let rec walk doc = match doc with
+ | Text _ | Nil | LineSuffix _ ->
+ false
+ | BreakParent ->
+ true
+ | LineBreak (Hard | Literal) ->
+ true
+ | LineBreak (Classic | Soft) ->
+ false
+ | Indent children ->
+ let childForcesBreak = walk children in
+ childForcesBreak
+ | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) ->
+ let falseForceBreak = walk falseDoc in
+ if falseForceBreak then
+ let _ = walk trueDoc in
+ ib.broken <- true;
+ true
+ else
+ let forceBreak = walk trueDoc in
+ forceBreak
+ | Group ({shouldBreak = forceBreak; doc = children} as gr) ->
+ let childForcesBreak = walk children in
+ let shouldBreak = forceBreak || childForcesBreak in
+ gr.shouldBreak <- shouldBreak;
+ shouldBreak
+ | Concat children ->
+ List.fold_left (fun forceBreak child ->
+ let childForcesBreak = walk child in
+ forceBreak || childForcesBreak
+ ) false children
+ | 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 _ = walk (Concat children) in
+ false
+ in
+ let _ = walk doc in
+ ()
+
+(* See documentation in interface file *)
+let rec willBreak doc = match doc with
+ | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> true
+ | Group {doc} | Indent doc | CustomLayout (doc::_) -> willBreak doc
+ | Concat docs -> List.exists willBreak docs
+ | IfBreaks {yes; no} -> willBreak yes || willBreak no
+ | _ -> false
+
+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 fits w stack =
+ let width = ref w in
+ let result = ref None in
+
+ let rec calculate indent mode doc =
+ match mode, doc with
+ | _ when result.contents != None -> ()
+ | _ when width.contents < 0 -> result := Some false
+ | _, Nil
+ | _, LineSuffix _
+ | _, BreakParent -> ()
+ | _, Text txt -> width := width.contents - (String.length txt)
+ | _, Indent doc -> calculate (indent + 2) mode doc
+ | Flat, LineBreak Hard
+ | Flat, LineBreak Literal -> result := Some true
+ | Flat, LineBreak Classic -> width := width.contents - 1
+ | Flat, LineBreak Soft -> ()
+ | Break, LineBreak _ -> result := Some true
+ | _, Group {shouldBreak = true; doc} -> calculate indent Break doc
+ | _, Group {doc} -> calculate indent mode doc
+ | _, IfBreaks {yes = breakDoc; broken = true} -> calculate indent mode breakDoc
+ | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc
+ | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc
+ | _, Concat docs -> calculateConcat indent mode docs
+ | _, CustomLayout (hd::_) ->
+ (* TODO: if we have nested custom layouts, what we should do here? *)
+ calculate indent mode hd
+ | _, CustomLayout [] -> ()
+ and calculateConcat indent mode docs =
+ if result.contents == None then (
+ match docs with
+ | [] -> ()
+ | doc::rest ->
+ calculate indent mode doc;
+ calculateConcat indent mode rest
+ )
+ in
+ let rec calculateAll stack =
+ match result.contents, stack with
+ | Some r, _ -> r
+ | None, [] -> !width >= 0
+ | None, (indent, mode, doc)::rest ->
+ calculate indent mode doc;
+ calculateAll rest
+ in
+ calculateAll stack
+
+let toString ~width doc =
+ propagateForcedBreaks doc;
+ 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; broken = true} ->
+ process ~pos lineSuffices ((ind, mode, breakDoc)::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
+ | [] ->
+ if lineStyle = Literal then (
+ MiniBuffer.add_char buffer '\n';
+ process ~pos:0 [] rest
+ ) else (
+ 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
+ | Literal -> MiniBuffer.add_char buffer '\n'; 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)];
+ 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 [] -> text "concat()"
+ | 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; broken = true} -> toDoc trueDoc
+ | 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"
+ | Literal -> "Liteal"
+ 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]
diff --git a/jscomp/napkin/res_doc.mli b/jscomp/napkin/res_doc.mli
new file mode 100644
index 0000000000..031afbaf66
--- /dev/null
+++ b/jscomp/napkin/res_doc.mli
@@ -0,0 +1,63 @@
+type t
+
+val nil: t
+val line: t
+val hardLine: t
+val softLine: t
+val literalLine: 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
+(* `customLayout docs` will pick the layout that fits from `docs`.
+ * This is a very expensive computation as every layout from the list
+ * will be checked until one fits. *)
+val customLayout: t list -> t
+val breakParent: t
+val 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 [@@live]
+
+(*
+ * `willBreak doc` checks whether `doc` contains forced line breaks.
+ * This is more or less a "workaround" to make the parent of a `customLayout` break.
+ * Forced breaks are not propagated through `customLayout`; otherwise we would always
+ * get the last layout the algorithm tries…
+ * This might result into some weird layouts:
+ * [fn(x => {
+ * let _ = x
+ * }), fn(y => {
+ * let _ = y
+ * }), fn(z => {
+ * let _ = z
+ * })]
+ * The `[` and `]` would be a lot better broken out.
+ * Although the layout of `fn(x => {...})` is correct, we need to break its parent (the array).
+ * `willBreak` can be used in this scenario to check if the `fn…` contains any forced breaks.
+ * The consumer can then manually insert a `breakParent` doc, to manually propagate the
+ * force breaks from bottom to top.
+ *)
+val willBreak: t -> bool
+
+val toString: width: int -> t -> string
+val debug: t -> unit [@@live]
diff --git a/jscomp/napkin/res_driver.ml b/jscomp/napkin/res_driver.ml
new file mode 100644
index 0000000000..d827880ac6
--- /dev/null
+++ b/jscomp/napkin/res_driver.ml
@@ -0,0 +1,109 @@
+module IO = Res_io
+
+type ('ast, 'diagnostics) parseResult = {
+ filename: string; [@live]
+ source: string;
+ parsetree: 'ast;
+ diagnostics: 'diagnostics;
+ invalid: bool;
+ comments: Res_comment.t list
+}
+
+type ('diagnostics) parsingEngine = {
+ parseImplementation:
+ forPrinter:bool -> filename:string
+ -> (Parsetree.structure, 'diagnostics) parseResult;
+ parseInterface:
+ forPrinter:bool -> filename:string
+ -> (Parsetree.signature, 'diagnostics) parseResult;
+ stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit
+}
+
+type printEngine = {
+ printImplementation:
+ width: int
+ -> filename: string
+ -> comments: Res_comment.t list
+ -> Parsetree.structure
+ -> unit;
+ printInterface:
+ width: int
+ -> filename: string
+ -> comments: Res_comment.t list
+ -> Parsetree.signature
+ -> unit;
+}
+
+let setup ~filename ~forPrinter () =
+ let src = IO.readFile ~filename in
+ let mode = if forPrinter then Res_parser.Default
+ else ParseForTypeChecker
+ in
+ Res_parser.make ~mode src filename
+
+let parsingEngine = {
+ parseImplementation = begin fun ~forPrinter ~filename ->
+ let engine = setup ~filename ~forPrinter () in
+ let structure = Res_core.parseImplementation engine in
+ let (invalid, diagnostics) = match engine.diagnostics with
+ | [] as diagnostics -> (false, diagnostics)
+ | _ as diagnostics -> (true, diagnostics)
+ in {
+ filename = engine.scanner.filename;
+ source = engine.scanner.src;
+ parsetree = structure;
+ diagnostics;
+ invalid;
+ comments = List.rev engine.comments;
+ }
+ end;
+ parseInterface = begin fun ~forPrinter ~filename ->
+ let engine = setup ~filename ~forPrinter () in
+ let signature = Res_core.parseSpecification engine in
+ let (invalid, diagnostics) = match engine.diagnostics with
+ | [] as diagnostics -> (false, diagnostics)
+ | _ as diagnostics -> (true, diagnostics)
+ in {
+ filename = engine.scanner.filename;
+ source = engine.scanner.src;
+ parsetree = signature;
+ diagnostics;
+ invalid;
+ comments = List.rev engine.comments;
+ }
+ end;
+ stringOfDiagnostics = begin fun ~source ~filename:_ diagnostics ->
+ Res_diagnostics.printReport diagnostics source
+ end;
+}
+
+let printEngine = {
+ printImplementation = begin fun ~width ~filename:_ ~comments structure ->
+ print_string (Res_printer.printImplementation ~width structure ~comments)
+ end;
+ printInterface = begin fun ~width ~filename:_ ~comments signature ->
+ print_string (Res_printer.printInterface ~width signature ~comments)
+ end;
+}
+
+let parse_implementation sourcefile =
+ Location.input_name := sourcefile;
+ let parseResult =
+ parsingEngine.parseImplementation ~forPrinter:false ~filename:sourcefile
+ in
+ if parseResult.invalid then begin
+ Res_diagnostics.printReport parseResult.diagnostics parseResult.source;
+ exit 1
+ end;
+ parseResult.parsetree
+[@@raises exit]
+
+let parse_interface sourcefile =
+ Location.input_name := sourcefile;
+ let parseResult = parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile in
+ if parseResult.invalid then begin
+ Res_diagnostics.printReport parseResult.diagnostics parseResult.source;
+ exit 1
+ end;
+ parseResult.parsetree
+[@@raises exit]
diff --git a/jscomp/napkin/res_driver.mli b/jscomp/napkin/res_driver.mli
new file mode 100644
index 0000000000..0facc0a52e
--- /dev/null
+++ b/jscomp/napkin/res_driver.mli
@@ -0,0 +1,49 @@
+type ('ast, 'diagnostics) parseResult = {
+ filename: string; [@live]
+ source: string;
+ parsetree: 'ast;
+ diagnostics: 'diagnostics;
+ invalid: bool;
+ comments: Res_comment.t list
+}
+
+type ('diagnostics) parsingEngine = {
+ parseImplementation:
+ forPrinter:bool -> filename:string
+ -> (Parsetree.structure, 'diagnostics) parseResult;
+ parseInterface:
+ forPrinter:bool -> filename:string
+ -> (Parsetree.signature, 'diagnostics) parseResult;
+ stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit
+}
+
+type printEngine = {
+ printImplementation:
+ width: int
+ -> filename: string
+ -> comments: Res_comment.t list
+ -> Parsetree.structure
+ -> unit;
+ printInterface:
+ width: int
+ -> filename: string
+ -> comments: Res_comment.t list
+ -> Parsetree.signature
+ -> unit;
+}
+
+val parsingEngine: (Res_diagnostics.t list) parsingEngine
+
+val printEngine: printEngine
+
+(* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *)
+val parse_implementation:
+ string -> Parsetree.structure
+[@@live]
+[@@raises Location.Error]
+
+(* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *)
+val parse_interface:
+ string -> Parsetree.signature
+[@@live]
+[@@raises Location.Error]
diff --git a/jscomp/napkin/res_driver_binary.ml b/jscomp/napkin/res_driver_binary.ml
new file mode 100644
index 0000000000..4085155782
--- /dev/null
+++ b/jscomp/napkin/res_driver_binary.ml
@@ -0,0 +1,12 @@
+let printEngine = Res_driver.{
+ printImplementation = begin fun ~width:_ ~filename ~comments:_ structure ->
+ output_string stdout Config.ast_impl_magic_number;
+ output_value stdout filename;
+ output_value stdout structure
+ end;
+ printInterface = begin fun ~width:_ ~filename ~comments:_ signature ->
+ output_string stdout Config.ast_intf_magic_number;
+ output_value stdout filename;
+ output_value stdout signature
+ end;
+}
diff --git a/jscomp/napkin/res_driver_binary.mli b/jscomp/napkin/res_driver_binary.mli
new file mode 100644
index 0000000000..7991ba8db3
--- /dev/null
+++ b/jscomp/napkin/res_driver_binary.mli
@@ -0,0 +1 @@
+val printEngine : Res_driver.printEngine
diff --git a/jscomp/napkin/res_driver_ml_parser.ml b/jscomp/napkin/res_driver_ml_parser.ml
new file mode 100644
index 0000000000..221a31c5da
--- /dev/null
+++ b/jscomp/napkin/res_driver_ml_parser.ml
@@ -0,0 +1,92 @@
+module OcamlParser = Parser
+module IO = Res_io
+
+let setup ~filename =
+ if String.length filename > 0 then (
+ Location.input_name := filename;
+ IO.readFile ~filename |> Lexing.from_string
+ ) else
+ Lexing.from_channel stdin
+
+let extractOcamlConcreteSyntax filename =
+ let lexbuf = if String.length filename > 0 then
+ IO.readFile ~filename |> Lexing.from_string
+ else
+ Lexing.from_channel stdin
+ in
+ let stringLocs = ref [] in
+ let commentData = ref [] in
+ let rec next (prevTokEndPos : Lexing.position) () =
+ let token = Lexer.token_with_comments lexbuf in
+ match token with
+ | OcamlParser.COMMENT (txt, loc) ->
+ let comment = Res_comment.fromOcamlComment
+ ~loc
+ ~prevTokEndPos
+ ~txt
+ in
+ commentData := comment::(!commentData);
+ next loc.Location.loc_end ()
+ | OcamlParser.STRING (_txt, None) ->
+ let open Location in
+ let loc = {
+ loc_start = lexbuf.lex_start_p;
+ loc_end = lexbuf.Lexing.lex_curr_p;
+ loc_ghost = false;
+ } in
+ let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in
+ let txt = Bytes.to_string (
+ (Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer loc.loc_start.pos_cnum len
+ ) in
+ stringLocs := (txt, loc)::(!stringLocs);
+ next lexbuf.Lexing.lex_curr_p ()
+ | OcamlParser.EOF -> ()
+ | _ -> next lexbuf.Lexing.lex_curr_p ()
+ in
+ next lexbuf.Lexing.lex_start_p ();
+ (List.rev !stringLocs, List.rev !commentData)
+
+let parsingEngine = {
+ Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename ->
+ let lexbuf = setup ~filename in
+ let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in
+ let structure =
+ Parse.implementation lexbuf
+ |> Res_ast_conversion.replaceStringLiteralStructure stringData
+ |> Res_ast_conversion.structure
+ in {
+ filename = !Location.input_name;
+ source = Bytes.to_string lexbuf.lex_buffer;
+ parsetree = structure;
+ diagnostics = ();
+ invalid = false;
+ comments = comments;
+ }
+ end;
+ parseInterface = begin fun ~forPrinter:_ ~filename ->
+ let lexbuf = setup ~filename in
+ let (stringData, comments) = extractOcamlConcreteSyntax !Location.input_name in
+ let signature =
+ Parse.interface lexbuf
+ |> Res_ast_conversion.replaceStringLiteralSignature stringData
+ |> Res_ast_conversion.signature
+ in {
+ filename = !Location.input_name;
+ source = Bytes.to_string lexbuf.lex_buffer;
+ parsetree = signature;
+ diagnostics = ();
+ invalid = false;
+ comments = comments;
+ }
+ end;
+ stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end;
+}
+
+let printEngine = Res_driver.{
+ printImplementation = begin fun ~width:_ ~filename:_ ~comments:_ structure ->
+ Pprintast.structure Format.std_formatter structure
+ end;
+ printInterface = begin fun ~width:_ ~filename:_ ~comments:_ signature ->
+ Pprintast.signature Format.std_formatter signature
+ end;
+}
diff --git a/jscomp/napkin/res_driver_ml_parser.mli b/jscomp/napkin/res_driver_ml_parser.mli
new file mode 100644
index 0000000000..4743e229af
--- /dev/null
+++ b/jscomp/napkin/res_driver_ml_parser.mli
@@ -0,0 +1,9 @@
+(* This module represents a general interface to parse marshalled reason ast *)
+
+(* extracts comments and the original string data from an ocaml file *)
+val extractOcamlConcreteSyntax :
+ string -> (string * Location.t) list * Res_comment.t list [@@live]
+
+val parsingEngine : unit Res_driver.parsingEngine
+
+val printEngine : Res_driver.printEngine
diff --git a/jscomp/napkin/res_driver_reason_binary.ml b/jscomp/napkin/res_driver_reason_binary.ml
new file mode 100644
index 0000000000..ad1beac74c
--- /dev/null
+++ b/jscomp/napkin/res_driver_reason_binary.ml
@@ -0,0 +1,103 @@
+module IO = Res_io
+
+let isReasonDocComment (comment: Res_comment.t) =
+ let content = Res_comment.txt comment in
+ let len = String.length content in
+ if len = 0 then true
+ else if len >= 2 && (String.unsafe_get content 0 = '*' && String.unsafe_get content 1 = '*') then false
+ else if len >= 1 && (String.unsafe_get content 0 = '*') then true
+ else false
+
+let extractConcreteSyntax filename =
+ let commentData = ref [] in
+ let stringData = ref [] in
+ let src = IO.readFile ~filename in
+ let scanner = Res_scanner.make src ~filename in
+
+ let rec next prevEndPos scanner =
+ let (startPos, endPos, token) = Res_scanner.scan scanner in
+ match token with
+ | Eof -> ()
+ | Comment c ->
+ Res_comment.setPrevTokEndPos c prevEndPos;
+ commentData := c::(!commentData);
+ next endPos scanner
+ | String _ ->
+ let loc = {Location.loc_start = startPos; loc_end = endPos; loc_ghost = false} in
+ let len = endPos.pos_cnum - startPos.pos_cnum in
+ let txt = (String.sub [@doesNotRaise]) src startPos.pos_cnum len in
+ stringData := (txt, loc)::(!stringData);
+ next endPos scanner;
+ | Lbrace ->
+ (* handle {| |} or {sql||sql} quoted strings. We don't care about its contents.
+ Why? // abcdef inside the quoted string would otherwise be picked up as an extra comment *)
+ Res_scanner.tryAdvanceQuotedString scanner;
+ next endPos scanner
+ | _ ->
+ next endPos scanner
+ in
+ next Lexing.dummy_pos scanner;
+ let comments =
+ !commentData
+ |> List.filter (fun c -> not (isReasonDocComment c))
+ |> List.rev
+ in
+ (comments, !stringData)
+
+let parsingEngine = {
+ Res_driver.parseImplementation = begin fun ~forPrinter:_ ~filename ->
+ let (chan, close) = if (String.length filename) == 0 then
+ (stdin, fun _ -> ())
+ else
+ let file_chan = open_in_bin filename in
+ let () = seek_in file_chan 0 in
+ file_chan, close_in_noerr
+ in
+ let magic = Config.ast_impl_magic_number in
+ ignore ((really_input_string [@doesNotRaise]) chan (String.length magic));
+ let filename = input_value chan in
+ let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in
+ let ast = input_value chan in
+ close chan;
+ let structure = ast
+ |> Res_ast_conversion.replaceStringLiteralStructure stringData
+ |> Res_ast_conversion.normalizeReasonArityStructure ~forPrinter:true
+ |> Res_ast_conversion.structure
+ in {
+ Res_driver.filename = filename;
+ source = "";
+ parsetree = structure;
+ diagnostics = ();
+ invalid = false;
+ comments = comments;
+ }
+ end;
+ parseInterface = begin fun ~forPrinter:_ ~filename ->
+ let (chan, close) = if String.length filename == 0 then
+ (stdin, fun _ -> ())
+ else
+ let file_chan = open_in_bin filename in
+ let () = seek_in file_chan 0 in
+ file_chan, close_in_noerr
+ in
+ let magic = Config.ast_intf_magic_number in
+ ignore ((really_input_string [@doesNotRaise]) chan (String.length magic));
+ let filename = input_value chan in
+ let (comments, stringData) = if filename <> "" then extractConcreteSyntax filename else ([], []) in
+ let ast = input_value chan in
+ close chan;
+ let signature = ast
+ |> Res_ast_conversion.replaceStringLiteralSignature stringData
+ |> Res_ast_conversion.normalizeReasonAritySignature ~forPrinter:true
+ |> Res_ast_conversion.signature
+ in {
+ Res_driver.filename;
+ source = "";
+ parsetree = signature;
+ diagnostics = ();
+ invalid = false;
+ comments = comments;
+ }
+ end;
+ stringOfDiagnostics = begin fun ~source:_ ~filename:_ _diagnostics -> () end;
+}
diff --git a/jscomp/napkin/res_driver_reason_binary.mli b/jscomp/napkin/res_driver_reason_binary.mli
new file mode 100644
index 0000000000..dce2d65ad3
--- /dev/null
+++ b/jscomp/napkin/res_driver_reason_binary.mli
@@ -0,0 +1,7 @@
+(* This module represents a general interface to parse marshalled reason ast *)
+
+(* extracts comments and the original string data from a reason file *)
+val extractConcreteSyntax :
+ string -> Res_token.Comment.t list * (string * Location.t) list
+
+val parsingEngine : unit Res_driver.parsingEngine
diff --git a/jscomp/napkin/res_grammar.ml b/jscomp/napkin/res_grammar.ml
new file mode 100644
index 0000000000..ac649a1e4d
--- /dev/null
+++ b/jscomp/napkin/res_grammar.ml
@@ -0,0 +1,368 @@
+module Token = Res_token
+
+type t =
+ | OpenDescription (* open Belt *)
+ | ModuleLongIdent (* Foo or Foo.Bar *) [@live]
+ | Ternary (* condExpr ? trueExpr : falseExpr *)
+ | Es6ArrowExpr
+ | Jsx
+ | JsxAttribute
+ | JsxChild [@live]
+ | ExprOperand
+ | ExprUnary
+ | ExprSetField
+ | ExprBinaryAfterOp of Token.t
+ | ExprBlock
+ | ExprCall
+ | ExprList
+ | ExprArrayAccess
+ | ExprArrayMutation
+ | ExprIf
+ | ExprFor
+ | IfCondition | IfBranch | ElseBranch
+ | TypeExpression
+ | External
+ | PatternMatching
+ | PatternMatchCase
+ | LetBinding
+ | PatternList
+ | PatternOcamlList
+ | PatternRecord
+
+ | TypeDef
+ | TypeConstrName
+ | TypeParams
+ | TypeParam [@live]
+ | PackageConstraint
+ | TypeRepresentation
+ | RecordDecl
+ | ConstructorDeclaration
+ | ParameterList
+ | StringFieldDeclarations
+ | FieldDeclarations
+ | TypExprList
+ | FunctorArgs
+ | ModExprList
+ | TypeParameters
+ | RecordRows
+ | RecordRowsStringKey
+ | ArgumentList
+ | Signature
+ | Specification
+ | Structure
+ | Implementation
+ | Attribute
+ | TypeConstraint
+ | AtomicTypExpr
+ | ListExpr
+ | JsFfiImport
+ | Pattern
+ | AttributePayload
+
+let toString = function
+ | OpenDescription -> "an open description"
+ | ModuleLongIdent -> "a module path"
+ | Ternary -> "a ternary expression"
+ | Es6ArrowExpr -> "an es6 arrow function"
+ | Jsx -> "a jsx expression"
+ | JsxAttribute -> "a jsx attribute"
+ | ExprOperand -> "a basic expression"
+ | ExprUnary -> "a unary expression"
+ | ExprBinaryAfterOp op -> "an expression after the operator \"" ^ Token.toString op ^ "\""
+ | ExprIf -> "an if expression"
+ | IfCondition -> "the condition of an if expression"
+ | IfBranch -> "the true-branch of an if expression"
+ | ElseBranch -> "the else-branch of an if expression"
+ | TypeExpression -> "a type"
+ | External -> "an external"
+ | PatternMatching -> "the cases of a pattern match"
+ | ExprBlock -> "a block with expressions"
+ | ExprSetField -> "a record field mutation"
+ | ExprCall -> "a function application"
+ | ExprArrayAccess -> "an array access expression"
+ | ExprArrayMutation -> "an array mutation"
+ | LetBinding -> "a let binding"
+ | TypeDef -> "a type definition"
+ | TypeParams -> "type parameters"
+ | TypeParam -> "a type parameter"
+ | TypeConstrName -> "a type-constructor name"
+ | TypeRepresentation -> "a type representation"
+ | RecordDecl -> "a record declaration"
+ | PatternMatchCase -> "a pattern match case"
+ | ConstructorDeclaration -> "a constructor declaration"
+ | ExprList -> "multiple expressions"
+ | PatternList -> "multiple patterns"
+ | PatternOcamlList -> "a list pattern"
+ | PatternRecord -> "a record pattern"
+ | ParameterList -> "parameters"
+ | StringFieldDeclarations -> "string field declarations"
+ | FieldDeclarations -> "field declarations"
+ | TypExprList -> "list of types"
+ | FunctorArgs -> "functor arguments"
+ | ModExprList -> "list of module expressions"
+ | TypeParameters -> "list of type parameters"
+ | RecordRows -> "rows of a record"
+ | RecordRowsStringKey -> "rows of a record with string keys"
+ | ArgumentList -> "arguments"
+ | Signature -> "signature"
+ | Specification -> "specification"
+ | Structure -> "structure"
+ | Implementation -> "implementation"
+ | Attribute -> "an attribute"
+ | TypeConstraint -> "constraints on a type"
+ | AtomicTypExpr -> "a type"
+ | ListExpr -> "an ocaml list expr"
+ | PackageConstraint -> "a package constraint"
+ | JsFfiImport -> "js ffi import"
+ | JsxChild -> "jsx child"
+ | Pattern -> "pattern"
+ | ExprFor -> "a for expression"
+ | AttributePayload -> "an attribute payload"
+
+let isSignatureItemStart = function
+ | Token.At
+ | Let
+ | Typ
+ | External
+ | Exception
+ | Open
+ | Include
+ | Module
+ | AtAt
+ | Export
+ | PercentPercent -> true
+ | _ -> false
+
+let isAtomicPatternStart = function
+ | Token.Int _ | String _ | Codepoint _ | Backtick
+ | Lparen | Lbracket | Lbrace
+ | Underscore
+ | Lident _ | Uident _ | List
+ | Exception | Lazy
+ | Percent -> true
+ | _ -> false
+
+let isAtomicExprStart = function
+ | Token.True | False
+ | Int _ | String _ | Float _ | Codepoint _
+ | 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 _ | Codepoint _ | 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 _ | Codepoint _ | Backtick | True | False | Minus | Plus
+ | Lparen | Lbracket | Lbrace | List
+ | Underscore
+ | Lident _ | Uident _ | Hash
+ | Exception | Lazy | Percent | Module
+ | At -> true
+ | _ -> false
+
+let isParameterStart = function
+ | Token.Typ | Tilde | Dot -> true
+ | token when isPatternStart token -> true
+ | _ -> false
+
+(* TODO: overparse Uident ? *)
+let isStringFieldDeclStart = function
+ | Token.String _ | Lident _ | At | DotDotDot -> true
+ | _ -> false
+
+(* TODO: overparse Uident ? *)
+let isFieldDeclStart = function
+ | Token.At | Mutable | Lident _ -> true
+ (* recovery, TODO: this is not ideal… *)
+ | Uident _ -> true
+ | t when Token.isKeyword t -> true
+ | _ -> false
+
+let isRecordDeclStart = function
+ | Token.At
+ | Mutable
+ | Lident _ -> true
+ | _ -> false
+
+let isTypExprStart = function
+ | Token.At
+ | SingleQuote
+ | Underscore
+ | Lparen | Lbracket
+ | Uident _ | Lident _
+ | Module
+ | Percent
+ | Lbrace -> true
+ | _ -> false
+
+let isTypeParameterStart = function
+ | Token.Tilde | Dot -> true
+ | token when isTypExprStart token -> true
+ | _ -> false
+
+let isTypeParamStart = function
+ | Token.Plus | Minus | SingleQuote | Underscore -> true
+ | _ -> false
+
+let isFunctorArgStart = function
+ | Token.At | Uident _ | Underscore
+ | Percent
+ | Lbrace
+ | Lparen -> true
+ | _ -> false
+
+let isModExprStart = function
+ | Token.At | Percent
+ | Uident _ | Lbrace | Lparen
+ | Lident "unpack" -> true
+ | _ -> false
+
+let isRecordRowStart = function
+ | Token.DotDotDot -> true
+ | Token.Uident _ | Lident _ -> true
+ (* TODO *)
+ | t when Token.isKeyword t -> true
+ | _ -> false
+
+let isRecordRowStringKeyStart = function
+ | Token.String _ -> true
+ | _ -> false
+
+let isArgumentStart = function
+ | Token.Tilde | Dot | Underscore -> true
+ | t when isExprStart t -> true
+ | _ -> false
+
+let isPatternMatchStart = function
+ | Token.Bar -> true
+ | t when isPatternStart t -> true
+ | _ -> false
+
+let isPatternOcamlListStart = function
+ | Token.DotDotDot -> true
+ | t when isPatternStart t -> true
+ | _ -> false
+
+let isPatternRecordItemStart = function
+ | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true
+ | _ -> false
+
+let isAttributeStart = function
+ | Token.At -> true
+ | _ -> false
+
+let isJsFfiImportStart = function
+ | Token.Lident _ | At -> true
+ | _ -> false
+
+let isJsxChildStart = isAtomicExprStart
+
+let isBlockExprStart = function
+ | Token.At | Hash | Percent | Minus | MinusDot | Plus | PlusDot | Bang
+ | True | False | Float _ | Int _ | String _ | Codepoint _ | Lident _ | Uident _
+ | Lparen | List | Lbracket | Lbrace | Forwardslash | Assert
+ | Lazy | If | For | While | Switch | Open | Module | Exception | Let
+ | LessThan | Backtick | Try | Underscore -> true
+ | _ -> false
+
+let isListElement grammar token =
+ match grammar with
+ | ExprList -> token = Token.DotDotDot || isExprStart token
+ | ListExpr -> token = DotDotDot || isExprStart token
+ | PatternList -> token = DotDotDot || isPatternStart token
+ | ParameterList -> isParameterStart token
+ | StringFieldDeclarations -> isStringFieldDeclStart token
+ | FieldDeclarations -> isFieldDeclStart token
+ | RecordDecl -> isRecordDeclStart token
+ | TypExprList -> isTypExprStart token || token = Token.LessThan
+ | TypeParams -> isTypeParamStart token
+ | FunctorArgs -> isFunctorArgStart token
+ | ModExprList -> isModExprStart token
+ | TypeParameters -> isTypeParameterStart token
+ | RecordRows -> isRecordRowStart token
+ | RecordRowsStringKey -> isRecordRowStringKeyStart token
+ | ArgumentList -> isArgumentStart token
+ | Signature | Specification -> isSignatureItemStart token
+ | Structure | Implementation -> isStructureItemStart token
+ | PatternMatching -> isPatternMatchStart token
+ | PatternOcamlList -> isPatternOcamlListStart token
+ | PatternRecord -> isPatternRecordItemStart token
+ | Attribute -> isAttributeStart token
+ | TypeConstraint -> token = Constraint
+ | PackageConstraint -> token = And
+ | ConstructorDeclaration -> token = Bar
+ | JsxAttribute -> isJsxAttributeStart token
+ | JsFfiImport -> isJsFfiImportStart token
+ | AttributePayload -> token = Lparen
+ | _ -> false
+
+let isListTerminator grammar token =
+ match grammar, token with
+ | _, Token.Eof
+ | ExprList, (Rparen | Forwardslash | Rbracket)
+ | ListExpr, Rparen
+ | ArgumentList, Rparen
+ | TypExprList, (Rparen | Forwardslash | GreaterThan | Equal)
+ | ModExprList, Rparen
+ | (PatternList | PatternOcamlList | PatternRecord),
+ (Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) | In (* for expressions *) | Equal (* let {x} = foo *))
+ | ExprBlock, Rbrace
+ | (Structure | Signature), Rbrace
+ | TypeParams, Rparen
+ | ParameterList, (EqualGreater | Lbrace)
+ | JsxAttribute, (Forwardslash | GreaterThan)
+ | JsFfiImport, Rbrace
+ | StringFieldDeclarations, Rbrace -> true
+
+ | Attribute, token when token <> At -> true
+ | TypeConstraint, token when token <> Constraint -> true
+ | PackageConstraint, token when token <> And -> true
+ | ConstructorDeclaration, token when token <> Bar -> true
+ | AttributePayload, Rparen -> true
+
+ | _ -> false
+
+let isPartOfList grammar token =
+ isListElement grammar token || isListTerminator grammar token
diff --git a/jscomp/napkin/res_io.ml b/jscomp/napkin/res_io.ml
new file mode 100644
index 0000000000..e5934b8483
--- /dev/null
+++ b/jscomp/napkin/res_io.ml
@@ -0,0 +1,14 @@
+let readFile ~filename =
+ let chan = open_in_bin filename in
+ let content =
+ try really_input_string chan (in_channel_length chan)
+ with End_of_file -> ""
+ in
+ close_in_noerr chan;
+ content
+
+let writeFile ~filename ~contents:txt =
+ let chan = open_out_bin filename in
+ output_string chan txt;
+ close_out chan
+[@@raises Sys_error]
diff --git a/jscomp/napkin/res_io.mli b/jscomp/napkin/res_io.mli
new file mode 100644
index 0000000000..6260c27c54
--- /dev/null
+++ b/jscomp/napkin/res_io.mli
@@ -0,0 +1,7 @@
+(* utilities to read and write to/from files or stdin *)
+
+(* reads the contents of "filename" into a string *)
+val readFile: filename: string -> string
+
+(* writes "content" into file with name "filename" *)
+val writeFile: filename: string -> contents: string -> unit
diff --git a/jscomp/napkin/res_js_ffi.ml b/jscomp/napkin/res_js_ffi.ml
new file mode 100644
index 0000000000..f8a082a19d
--- /dev/null
+++ b/jscomp/napkin/res_js_ffi.ml
@@ -0,0 +1,116 @@
+(* AST for js externals *)
+type scope =
+ | Global
+ | Module of string (* bs.module("path") *)
+ | Scope of Longident.t (* bs.scope(/"window", "location"/) *)
+
+type label_declaration = {
+ jld_attributes: Parsetree.attributes; [@live]
+ jld_name: string;
+ jld_alias: string;
+ jld_type: Parsetree.core_type;
+ jld_loc: Location.t
+}
+
+type importSpec =
+ | Default of label_declaration
+ | Spec of label_declaration list
+
+type import_description = {
+ jid_loc: Location.t;
+ jid_spec: importSpec;
+ jid_scope: scope;
+ jid_attributes: Parsetree.attributes;
+}
+
+let decl ~attrs ~loc ~name ~alias ~typ = {
+ jld_loc = loc;
+ jld_attributes = attrs;
+ jld_name = name;
+ jld_alias = alias;
+ jld_type = typ
+}
+
+let importDescr ~attrs ~scope ~importSpec ~loc = {
+ jid_loc = loc;
+ jid_spec = importSpec;
+ jid_scope = scope;
+ jid_attributes = attrs;
+}
+
+let toParsetree importDescr =
+ let bsVal = (Location.mknoloc "val", Parsetree.PStr []) in
+ let attrs = match importDescr.jid_scope with
+ | Global -> [bsVal]
+ (* @genType.import("./MyMath"),
+ * @genType.import(/"./MyMath", "default"/) *)
+ | Module s ->
+ let structure = [
+ Parsetree.Pconst_string (s, None)
+ |> Ast_helper.Exp.constant
+ |> Ast_helper.Str.eval
+ ] in
+ let genType = (Location.mknoloc "genType.import", Parsetree.PStr structure) in
+ [genType]
+ | Scope longident ->
+ let structureItem =
+ let expr = match Longident.flatten longident |> List.map (fun s ->
+ Ast_helper.Exp.constant (Parsetree.Pconst_string (s, None))
+ ) with
+ | [expr] -> expr
+ | [] as exprs | (_ as exprs) -> exprs |> Ast_helper.Exp.tuple
+ in
+ Ast_helper.Str.eval expr
+ in
+ let bsScope = (
+ Location.mknoloc "scope",
+ Parsetree. PStr [structureItem]
+ ) in
+ [bsVal; bsScope]
+ in
+ let valueDescrs = match importDescr.jid_spec with
+ | Default decl ->
+ let prim = [decl.jld_name] in
+ let allAttrs =
+ List.concat [attrs; importDescr.jid_attributes]
+ |> List.map (fun attr -> match attr with
+ | (
+ {Location.txt = "genType.import"} as id,
+ Parsetree.PStr [{pstr_desc = Parsetree.Pstr_eval (moduleName, _) }]
+ ) ->
+ let default =
+ Parsetree.Pconst_string ("default", None) |> Ast_helper.Exp.constant
+ in
+ let structureItem =
+ [moduleName; default]
+ |> Ast_helper.Exp.tuple
+ |> Ast_helper.Str.eval
+ in
+ (id, Parsetree.PStr [structureItem])
+ | attr -> attr
+ )
+ in
+ [Ast_helper.Val.mk
+ ~loc:importDescr.jid_loc
+ ~prim
+ ~attrs:allAttrs
+ (Location.mknoloc decl.jld_alias)
+ decl.jld_type
+ |> Ast_helper.Str.primitive]
+ | Spec decls ->
+ List.map (fun decl ->
+ let prim = [decl.jld_name] in
+ let allAttrs = List.concat [attrs; decl.jld_attributes] in
+ Ast_helper.Val.mk
+ ~loc:importDescr.jid_loc
+ ~prim
+ ~attrs:allAttrs
+ (Location.mknoloc decl.jld_alias)
+ decl.jld_type
+ |> Ast_helper.Str.primitive ~loc:decl.jld_loc
+ ) decls
+ in
+ let jsFfiAttr = (Location.mknoloc "ns.jsFfi", Parsetree.PStr []) in
+ Ast_helper.Mod.structure ~loc:importDescr.jid_loc valueDescrs
+ |> Ast_helper.Incl.mk ~attrs:[jsFfiAttr] ~loc:importDescr.jid_loc
+ |> Ast_helper.Str.include_ ~loc:importDescr.jid_loc
diff --git a/jscomp/napkin/res_minibuffer.ml b/jscomp/napkin/res_minibuffer.ml
new file mode 100644
index 0000000000..174b5ec6a2
--- /dev/null
+++ b/jscomp/napkin/res_minibuffer.ml
@@ -0,0 +1,50 @@
+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 [@doesNotRaise]) b.buffer 0 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'
diff --git a/jscomp/napkin/res_minibuffer.mli b/jscomp/napkin/res_minibuffer.mli
new file mode 100644
index 0000000000..0a2bffa538
--- /dev/null
+++ b/jscomp/napkin/res_minibuffer.mli
@@ -0,0 +1,6 @@
+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
diff --git a/jscomp/napkin/res_multi_printer.ml b/jscomp/napkin/res_multi_printer.ml
new file mode 100644
index 0000000000..cfcf19427e
--- /dev/null
+++ b/jscomp/napkin/res_multi_printer.ml
@@ -0,0 +1,128 @@
+module IO = Res_io
+
+let defaultPrintWidth = 100
+
+(* print res files to res syntax *)
+let printRes ~isInterface ~filename =
+ if isInterface then
+ let parseResult =
+ Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename
+ in
+ if parseResult.invalid then
+ begin
+ Res_diagnostics.printReport parseResult.diagnostics parseResult.source;
+ exit 1
+ end
+ else
+ Res_printer.printInterface
+ ~width:defaultPrintWidth
+ ~comments:parseResult.comments
+ parseResult.parsetree
+ else
+ let parseResult =
+ Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename
+ in
+ if parseResult.invalid then
+ begin
+ Res_diagnostics.printReport parseResult.diagnostics parseResult.source;
+ exit 1
+ end
+ else
+ Res_printer.printImplementation
+ ~width:defaultPrintWidth
+ ~comments:parseResult.comments
+ parseResult.parsetree
+[@@raises exit]
+
+(* print ocaml files to res syntax *)
+let printMl ~isInterface ~filename =
+ if isInterface then
+ let parseResult =
+ Res_driver_ml_parser.parsingEngine.parseInterface ~forPrinter:true ~filename in
+ Res_printer.printInterface
+ ~width:defaultPrintWidth
+ ~comments:parseResult.comments
+ parseResult.parsetree
+ else
+ let parseResult =
+ Res_driver_ml_parser.parsingEngine.parseImplementation ~forPrinter:true ~filename in
+ Res_printer.printImplementation
+ ~width:defaultPrintWidth
+ ~comments:parseResult.comments
+ parseResult.parsetree
+
+(* How does printing Reason to Res work?
+ * -> open a tempfile
+ * -> write the source code found in "filename" into the tempfile
+ * -> run refmt in-place in binary mode on the tempfile,
+ * mutates contents tempfile with marshalled AST.j
+ * -> read the marshalled ast (from the binary output in the tempfile)
+ * -> re-read the original "filename" and extract string + comment data
+ * -> put the comment- and string data back into the unmarshalled parsetree
+ * -> pretty print to res
+ * -> take a deep breath and exhale slowly *)
+let printReason ~refmtPath ~isInterface ~filename =
+ (* open a tempfile *)
+ let (tempFilename, chan) =
+ (* refmt is just a prefix, `open_temp_file` takes care of providing a random name
+ * It tries 1000 times in the case of a name conflict.
+ * In practise this means that we shouldn't worry too much about filesystem races *)
+ Filename.open_temp_file "refmt" (if isInterface then ".rei" else ".re") in
+ close_out chan;
+ (* Write the source code found in "filename" into the tempfile *)
+ IO.writeFile ~filename:tempFilename ~contents:(IO.readFile ~filename);
+ let cmd = Printf.sprintf "%s --print=binary --in-place --interface=%b %s" refmtPath isInterface tempFilename in
+ (* run refmt in-place in binary mode on the tempfile *)
+ ignore (Sys.command cmd);
+ let result =
+ if isInterface then
+ let parseResult =
+ (* read the marshalled ast (from the binary output in the tempfile) *)
+ Res_driver_reason_binary.parsingEngine.parseInterface ~forPrinter:true ~filename:tempFilename in
+ (* re-read the original "filename" and extract string + comment data *)
+ let (comments, stringData) = Res_driver_reason_binary.extractConcreteSyntax filename in
+ (* put the comment- and string data back into the unmarshalled parsetree *)
+ let parseResult = {
+ parseResult with
+ parsetree =
+ parseResult.parsetree |> Res_ast_conversion.replaceStringLiteralSignature stringData;
+ comments = comments;
+ } in
+ (* pretty print to res *)
+ Res_printer.printInterface
+ ~width:defaultPrintWidth
+ ~comments:parseResult.comments
+ parseResult.parsetree
+ else
+ let parseResult =
+ (* read the marshalled ast (from the binary output in the tempfile) *)
+ Res_driver_reason_binary.parsingEngine.parseImplementation ~forPrinter:true ~filename:tempFilename in
+ let (comments, stringData) = Res_driver_reason_binary.extractConcreteSyntax filename in
+ (* put the comment- and string data back into the unmarshalled parsetree *)
+ let parseResult = {
+ parseResult with
+ parsetree =
+ parseResult.parsetree |> Res_ast_conversion.replaceStringLiteralStructure stringData;
+ comments = comments;
+ } in
+ (* pretty print to res *)
+ Res_printer.printImplementation
+ ~width:defaultPrintWidth
+ ~comments:parseResult.comments
+ parseResult.parsetree
+ in
+ Sys.remove tempFilename;
+ result
+[@@raises Sys_error]
+
+(* print the given file named input to from "language" to res, general interface exposed by the compiler *)
+let print language ~input =
+ let isInterface =
+ let len = String.length input in
+ len > 0 && String.unsafe_get input (len - 1) = 'i'
+ in
+ match language with
+ | `res -> printRes ~isInterface ~filename:input
+ | `ml -> printMl ~isInterface ~filename:input
+ | `refmt path -> printReason ~refmtPath:path ~isInterface ~filename:input
+[@@raises Sys_error, exit]
diff --git a/jscomp/napkin/res_multi_printer.mli b/jscomp/napkin/res_multi_printer.mli
new file mode 100644
index 0000000000..1a1d9624d6
--- /dev/null
+++ b/jscomp/napkin/res_multi_printer.mli
@@ -0,0 +1,3 @@
+(* Interface to print source code from different languages to res.
+ * Takes a filename called "input" and returns the corresponding formatted res syntax *)
+val print: [`ml | `res | `refmt of string (* path to refmt *)] -> input: string -> string
diff --git a/jscomp/napkin/res_outcome_printer.ml b/jscomp/napkin/res_outcome_printer.ml
new file mode 100644
index 0000000000..bfa10d8ca9
--- /dev/null
+++ b/jscomp/napkin/res_outcome_printer.ml
@@ -0,0 +1,1211 @@
+(* For the curious: the outcome printer is a printer to print data
+ * from the outcometree.mli file in the ocaml compiler.
+ * The outcome tree is used by:
+ * - ocaml's toplevel/repl, print results/errors
+ * - super errors, print nice errors
+ * - editor tooling, e.g. show type on hover
+ *
+ * In general it represent messages to show results or errors to the user. *)
+
+module Doc = Res_doc
+module Token = Res_token
+
+let rec unsafe_for_all_range s ~start ~finish p =
+ start > finish ||
+ p (String.unsafe_get s start) &&
+ unsafe_for_all_range s ~start:(start + 1) ~finish p
+
+let for_all_from s start p =
+ let len = String.length s in
+ unsafe_for_all_range s ~start ~finish:(len - 1) p
+
+(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *)
+let isValidNumericPolyvarNumber (x : string) =
+ let len = String.length x in
+ len > 0 && (
+ let a = Char.code (String.unsafe_get x 0) in
+ a <= 57 &&
+ (if len > 1 then
+ a > 48 &&
+ for_all_from x 1 (function '0' .. '9' -> true | _ -> false)
+ else
+ a >= 48 )
+ )
+
+(* checks if ident contains "arity", like in "arity1", "arity2", "arity3" etc. *)
+let isArityIdent ident =
+ if String.length ident >= 6 then
+ (String.sub [@doesNotRaise]) ident 0 5 = "arity"
+ else
+ false
+
+type identifierStyle =
+ | ExoticIdent
+ | NormalIdent
+
+let classifyIdentContent ~allowUident txt =
+ let len = String.length txt in
+ let rec go i =
+ if i == len then NormalIdent
+ else
+ let c = String.unsafe_get txt i in
+ if i == 0 && not (
+ (allowUident && (c >= 'A' && c <= 'Z')) ||
+ (c >= 'a' && c <= 'z') || c = '_') then
+ ExoticIdent
+ else if not (
+ (c >= 'a' && c <= 'z')
+ || (c >= 'A' && c <= 'Z')
+ || c = '\''
+ || c = '_'
+ || (c >= '0' && c <= '9'))
+ then
+ ExoticIdent
+ else
+ go (i + 1)
+ in
+ if Token.isKeywordTxt txt then
+ ExoticIdent
+ else
+ go 0
+
+let printIdentLike ~allowUident txt =
+ match classifyIdentContent ~allowUident txt with
+ | ExoticIdent -> Doc.concat [
+ Doc.text "\\\"";
+ Doc.text txt;
+ Doc.text"\""
+ ]
+ | NormalIdent -> Doc.text txt
+
+let printPolyVarIdent txt =
+ (* numeric poly-vars don't need quotes: #644 *)
+ if isValidNumericPolyvarNumber txt then
+ Doc.text txt
+ else
+ match classifyIdentContent ~allowUident:true txt with
+ | ExoticIdent -> Doc.concat [
+ Doc.text "\"";
+ Doc.text txt;
+ Doc.text"\""
+ ]
+ | NormalIdent -> Doc.text txt
+
+ (* ReScript doesn't have parenthesized identifiers.
+ * We don't support custom operators. *)
+ let parenthesized_ident _name = true
+
+ (* TODO: better allocation strategy for the buffer *)
+ let escapeStringContents s =
+ let 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 ?(allowUident=true) (ident : Outcometree.out_ident) =
+ match ident with
+ | Oide_ident s -> printIdentLike ~allowUident 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_open -> Doc.nil
+ | Otyp_variant (nonGen, outVariant, closed, labels) ->
+ (* bool * out_variant * bool * (string list) option *)
+ let opening = match (closed, labels) with
+ | (true, None) -> (* [#A | #B] *) Doc.softLine
+ | (false, None) ->
+ (* [> #A | #B] *)
+ Doc.concat [Doc.greaterThan; Doc.line]
+ | (true, Some []) ->
+ (* [< #A | #B] *)
+ Doc.concat [Doc.lessThan; Doc.line]
+ | (true, Some _) ->
+ (* [< #A | #B > #X #Y ] *)
+ Doc.concat [Doc.lessThan; Doc.line]
+ | (false, Some _) ->
+ (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *)
+ Doc.concat [Doc.text "?"; Doc.line]
+ in
+ Doc.group (
+ Doc.concat [
+ if nonGen then Doc.text "_" else Doc.nil;
+ Doc.lbracket;
+ Doc.indent (
+ Doc.concat [
+ opening;
+ printOutVariant outVariant
+ ]
+ );
+ begin match labels with
+ | None | Some [] -> Doc.nil
+ | Some tags ->
+ Doc.group (
+ Doc.concat [
+ Doc.space;
+ Doc.join ~sep:Doc.space (
+ List.map (fun lbl -> printIdentLike ~allowUident:true lbl) tags
+ )
+ ]
+ )
+ end;
+ Doc.softLine;
+ Doc.rbracket;
+ ]
+ )
+ | Otyp_alias (typ, aliasTxt) ->
+ Doc.concat [
+ printOutTypeDoc typ;
+ Doc.text " as '";
+ Doc.text aliasTxt
+ ]
+ | Otyp_constr (
+ Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , "arity0"), (* Js.Fn.arity0 *)
+ [Otyp_constr (Oide_ident ident, [])] (* int or unit or string *)
+ ) ->
+ (* Js.Fn.arity0 -> (.) => int*)
+ Doc.concat [
+ Doc.text "(.) => ";
+ Doc.text ident;
+ ]
+ | Otyp_constr (
+ Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , ident), (* Js.Fn.arity2 *)
+ [(Otyp_arrow _) as arrowType] (* (int, int) => int *)
+ ) when isArityIdent ident ->
+ (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*)
+ printOutArrowType ~uncurried:true arrowType
+ | Otyp_constr (outIdent, []) ->
+ printOutIdentDoc ~allowUident:false 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
+ );
+ Doc.dot;
+ Doc.space;
+ printOutTypeDoc outType;
+ ]
+ )
+ | Otyp_arrow _ as typ ->
+ printOutArrowType ~uncurried:false typ
+ | Otyp_module (modName, stringList, outTypes) ->
+ let packageTypeDoc = match (stringList, outTypes) with
+ | [], [] -> Doc.nil
+ | labels, types ->
+ let i = ref 0 in
+ let package = Doc.join ~sep:Doc.line ((List.map2 [@doesNotRaise]) (fun lbl typ ->
+ Doc.concat [
+ Doc.text (if i.contents > 0 then "and " else "with ");
+ Doc.text lbl;
+ Doc.text " = ";
+ printOutTypeDoc typ;
+ ]
+ ) labels types)
+ in
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ package
+ ]
+ )
+ in
+ Doc.concat [
+ Doc.text "module";
+ Doc.lparen;
+ Doc.text modName;
+ packageTypeDoc;
+ Doc.rparen;
+ ]
+
+ and printOutArrowType ~uncurried typ =
+ let (typArgs, typ) = collectArrowArgs typ [] in
+ let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun (lbl, typ) ->
+ let lblLen = String.length lbl in
+ if lblLen = 0 then
+ printOutTypeDoc typ
+ else
+ let (lbl, optionalIndicator) =
+ (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *)
+ match String.unsafe_get lbl 0 with
+ | '?' -> ((String.sub [@doesNotRaise]) lbl 1 (lblLen - 1) , Doc.text "=?")
+ | _ -> (lbl, Doc.nil)
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.text ("~" ^ lbl ^ ": ");
+ printOutTypeDoc typ;
+ optionalIndicator
+ ]
+ )
+ ) typArgs
+ ) in
+ let argsDoc =
+ let needsParens = match typArgs with
+ | _ when uncurried -> true
+ | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true
+ (* single argument should not be wrapped *)
+ | ["", _] -> false
+ | _ -> true
+ in
+ if needsParens then
+ Doc.group (
+ Doc.concat [
+ if uncurried then Doc.text "(. " else Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ args;
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ else args
+ in
+ Doc.concat [
+ argsDoc;
+ Doc.text " => ";
+ printOutTypeDoc typ;
+ ]
+
+
+ and printOutVariant variant = match variant with
+ | Ovar_fields fields -> (* (string * bool * out_type list) list *)
+ Doc.join ~sep:Doc.line (
+ (*
+ * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand
+ * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand
+ *)
+ List.mapi (fun i (name, ampersand, types) ->
+ let needsParens = match types with
+ | [(Outcometree.Otyp_tuple _)] -> false
+ | _ -> true
+ in
+ Doc.concat [
+ if i > 0 then
+ Doc.text "| "
+ else
+ Doc.ifBreaks (Doc.text "| ") Doc.nil;
+ Doc.group (
+ Doc.concat [
+ Doc.text "#";
+ printPolyVarIdent name;
+ match types with
+ | [] -> Doc.nil
+ | types ->
+ Doc.concat [
+ if ampersand then Doc.text " & " else Doc.nil;
+ Doc.indent (
+ Doc.concat [
+ Doc.join ~sep:(Doc.concat [Doc.text " &"; Doc.line])
+ (List.map (fun typ ->
+ let outTypeDoc = printOutTypeDoc typ in
+ if needsParens then
+ Doc.concat [Doc.lparen; outTypeDoc; Doc.rparen]
+ else
+ outTypeDoc
+ ) types)
+ ];
+ );
+ ]
+ ]
+ )
+ ]
+ ) fields
+ )
+ | Ovar_typ typ -> printOutTypeDoc typ
+
+ and printObjectFields fields rest =
+ let dots = match rest with
+ | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..")
+ | None -> if fields = [] then Doc.dot else 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.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+
+
+ and printOutConstructorsDoc constructors =
+ Doc.group (
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ 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;
+ printIdentLike ~allowUident:false 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 ->
+ let prim = if prim <> "" && (prim.[0] [@doesNotRaise]) = '\132' then "#rescript-external" else prim in
+ (* not display those garbage '\132' is a magic number for marshal *)
+ 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.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.space;
+ printOutTypeDoc typ2;
+ ]
+ )
+ ) outTypeDecl.otype_cstrs)
+ ]
+ )
+ ) in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ Doc.group (
+ Doc.concat [
+ attrs;
+ kw;
+ printIdentLike ~allowUident:false 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 ";
+ printIdentLike ~allowUident:false 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 ";
+ printIdentLike ~allowUident:false 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 ReScript *)
+ | 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 ReScript *)
+(* 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
+
diff --git a/jscomp/napkin/res_outcome_printer.mli b/jscomp/napkin/res_outcome_printer.mli
new file mode 100644
index 0000000000..674a5eeb14
--- /dev/null
+++ b/jscomp/napkin/res_outcome_printer.mli
@@ -0,0 +1,16 @@
+(* For the curious: the outcome printer is a printer to print data
+ * from the outcometree.mli file in the ocaml compiler.
+ * The outcome tree is used by:
+ * - ocaml's toplevel/repl, print results/errors
+ * - super errors, print nice errors
+ * - editor tooling, e.g. show type on hover
+ *
+ * In general it represent messages to show results or errors to the user. *)
+
+val parenthesized_ident : string -> bool [@@live]
+
+val setup : unit lazy_t [@@live]
+
+(* Needed for e.g. the playground to print typedtree data *)
+val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live]
+val printOutSigItemDoc : Outcometree.out_sig_item -> Res_doc.t [@@live]
diff --git a/jscomp/napkin/res_parens.ml b/jscomp/napkin/res_parens.ml
new file mode 100644
index 0000000000..948f369259
--- /dev/null
+++ b/jscomp/napkin/res_parens.ml
@@ -0,0 +1,416 @@
+module ParsetreeViewer = Res_parsetree_viewer
+type kind = Parenthesized | Braced of Location.t | Nothing
+
+ let expr expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | _ ->
+ begin match expr with
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_constraint _ } -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let callExpr expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | _ ->
+ begin match expr with
+ | {Parsetree.pexp_attributes = attrs} when
+ begin match ParsetreeViewer.filterParsingAttrs attrs with
+ | _::_ -> true
+ | [] -> false
+ end
+ -> Parenthesized
+ | _ when ParsetreeViewer.isUnaryExpression expr || ParsetreeViewer.isBinaryExpression expr -> Parenthesized
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_fun _}
+ when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing
+ | {pexp_desc =
+ Pexp_lazy _
+ | Pexp_assert _
+ | Pexp_fun _
+ | Pexp_newtype _
+ | Pexp_function _
+ | Pexp_constraint _
+ | Pexp_setfield _
+ | Pexp_match _
+ | Pexp_try _
+ | Pexp_while _
+ | Pexp_for _
+ | Pexp_ifthenelse _
+ } -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let structureExpr expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | _ when ParsetreeViewer.hasAttributes expr.pexp_attributes &&
+ not (ParsetreeViewer.isJsxExpression expr) -> Parenthesized
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_constraint _ } -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let unaryExprOperand expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_attributes = attrs} when
+ begin match ParsetreeViewer.filterParsingAttrs attrs with
+ | _::_ -> true
+ | [] -> false
+ end
+ -> Parenthesized
+ | expr when
+ ParsetreeViewer.isUnaryExpression expr ||
+ ParsetreeViewer.isBinaryExpression expr
+ -> Parenthesized
+ | {pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_fun _}
+ when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing
+ | {pexp_desc =
+ Pexp_lazy _
+ | Pexp_assert _
+ | Pexp_fun _
+ | Pexp_newtype _
+ | Pexp_function _
+ | Pexp_constraint _
+ | Pexp_setfield _
+ | Pexp_extension _ (* readability? maybe remove *)
+ | Pexp_match _
+ | Pexp_try _
+ | Pexp_while _
+ | Pexp_for _
+ | Pexp_ifthenelse _
+ } -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let binaryExprOperand ~isLhs expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_fun _}
+ when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing
+ | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _} -> Parenthesized
+ | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized
+ | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized
+ | {pexp_desc =
+ Pexp_lazy _
+ | Pexp_assert _
+ } when isLhs -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let subBinaryExprOperand parentOperator childOperator =
+ let precParent = ParsetreeViewer.operatorPrecedence parentOperator in
+ let precChild = ParsetreeViewer.operatorPrecedence childOperator in
+ precParent > precChild ||
+ (precParent == precChild &&
+ not (ParsetreeViewer.flattenableOperators parentOperator childOperator)) ||
+ (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *)
+ (parentOperator = "||" && childOperator = "&&")
+
+ let rhsBinaryExprOperand parentOperator rhs =
+ match rhs.Parsetree.pexp_desc with
+ | Parsetree.Pexp_apply(
+ {pexp_attributes = [];
+ pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}},
+ [_, _left; _, _right]
+ ) when ParsetreeViewer.isBinaryOperator operator &&
+ not (operatorLoc.loc_ghost && operator = "^") ->
+ let precParent = ParsetreeViewer.operatorPrecedence parentOperator in
+ let precChild = ParsetreeViewer.operatorPrecedence operator in
+ precParent == precChild
+ | _ -> false
+
+ let flattenOperandRhs parentOperator rhs =
+ match rhs.Parsetree.pexp_desc with
+ | Parsetree.Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}},
+ [_, _left; _, _right]
+ ) when ParsetreeViewer.isBinaryOperator operator &&
+ not (operatorLoc.loc_ghost && operator = "^") ->
+ let precParent = ParsetreeViewer.operatorPrecedence parentOperator in
+ let precChild = ParsetreeViewer.operatorPrecedence operator in
+ precParent >= precChild || rhs.pexp_attributes <> []
+ | Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ ) -> false
+ | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false
+ | Pexp_fun _
+ | Pexp_newtype _
+ | Pexp_setfield _
+ | Pexp_constraint _ -> true
+ | _ when ParsetreeViewer.isTernaryExpr rhs -> true
+ | _ -> false
+
+ let lazyOrAssertExprRhs expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_attributes = attrs} when
+ begin match ParsetreeViewer.filterParsingAttrs attrs with
+ | _::_ -> true
+ | [] -> false
+ end
+ -> Parenthesized
+ | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized
+ | {pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_fun _}
+ when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing
+ | {pexp_desc =
+ Pexp_lazy _
+ | Pexp_assert _
+ | Pexp_fun _
+ | Pexp_newtype _
+ | Pexp_function _
+ | Pexp_constraint _
+ | Pexp_setfield _
+ | Pexp_match _
+ | Pexp_try _
+ | Pexp_while _
+ | Pexp_for _
+ | Pexp_ifthenelse _
+ } -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let isNegativeConstant constant =
+ let isNeg txt =
+ let len = String.length txt in
+ len > 0 && (String.get [@doesNotRaise]) txt 0 = '-'
+ in
+ match constant with
+ | Parsetree.Pconst_integer (i, _) | Pconst_float (i, _) when isNeg i -> true
+ | _ -> false
+
+ let fieldExpr expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_attributes = attrs} when
+ begin match ParsetreeViewer.filterParsingAttrs attrs with
+ | _::_ -> true
+ | [] -> false
+ end
+ -> Parenthesized
+ | expr when
+ ParsetreeViewer.isBinaryExpression expr ||
+ ParsetreeViewer.isUnaryExpression expr
+ -> Parenthesized
+ | {pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_constant c } when isNegativeConstant c -> Parenthesized
+ | {pexp_desc = Pexp_fun _}
+ when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing
+ | {pexp_desc =
+ Pexp_lazy _
+ | Pexp_assert _
+ | Pexp_extension _ (* %extension.x vs (%extension).x *)
+ | Pexp_fun _
+ | Pexp_newtype _
+ | Pexp_function _
+ | Pexp_constraint _
+ | Pexp_setfield _
+ | Pexp_match _
+ | Pexp_try _
+ | Pexp_while _
+ | Pexp_for _
+ | Pexp_ifthenelse _
+ } -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let setFieldExprRhs expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_constraint _ } -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let ternaryOperand expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ )} -> Nothing
+ | {pexp_desc = Pexp_constraint _ } -> Parenthesized
+ | {pexp_desc = Pexp_fun _ | Pexp_newtype _} ->
+ let (_attrsOnArrow, _parameters, returnExpr) = ParsetreeViewer.funExpr expr in
+ begin match returnExpr.pexp_desc with
+ | Pexp_constraint _ -> Parenthesized
+ | _ -> Nothing
+ end
+ | _ -> Nothing
+ end
+
+ let startsWithMinus txt =
+ let len = String.length txt in
+ if len == 0 then
+ false
+ else
+ let s = (String.get [@doesNotRaise]) txt 0 in
+ s = '-'
+
+ let jsxPropExpr expr =
+ match expr.Parsetree.pexp_desc with
+ | Parsetree.Pexp_let _
+ | Pexp_sequence _
+ | Pexp_letexception _
+ | Pexp_letmodule _
+ | Pexp_open _ -> Nothing
+ | _ ->
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ begin match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_desc =
+ Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _));
+ pexp_attributes = []}
+ when startsWithMinus x -> Parenthesized
+ | {Parsetree.pexp_desc =
+ Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ |
+ Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ |
+ Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ |
+ Pexp_let _ | Pexp_tuple _;
+ pexp_attributes = []
+ } -> Nothing
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ ); pexp_attributes = []} -> Nothing
+ | _ -> Parenthesized
+ end
+ end
+
+ let jsxChildExpr expr =
+ match expr.Parsetree.pexp_desc with
+ | Parsetree.Pexp_let _
+ | Pexp_sequence _
+ | Pexp_letexception _
+ | Pexp_letmodule _
+ | Pexp_open _ -> Nothing
+ | _ ->
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ begin match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | _ ->
+ begin match expr with
+ | {Parsetree.pexp_desc = Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _));
+ pexp_attributes = []
+ } when startsWithMinus x -> Parenthesized
+ | {Parsetree.pexp_desc =
+ Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ |
+ Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ |
+ Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ |
+ Pexp_let _;
+ pexp_attributes = []
+ } -> Nothing
+ | {Parsetree.pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ ); pexp_attributes = []} -> Nothing
+ | expr when ParsetreeViewer.isJsxExpression expr -> Nothing
+ | _ -> Parenthesized
+ end
+ end
+
+ let binaryExpr expr =
+ let optBraces, _ = ParsetreeViewer.processBracesAttr expr in
+ match optBraces with
+ | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc)
+ | None ->
+ begin match expr with
+ | {Parsetree.pexp_attributes = _::_} as expr
+ when ParsetreeViewer.isBinaryExpression expr -> Parenthesized
+ | _ -> Nothing
+ end
+
+ let modTypeFunctorReturn modType = match modType with
+ | {Parsetree.pmty_desc = Pmty_with _} -> true
+ | _ -> false
+
+ (* Add parens for readability:
+ module type Functor = SetLike => Set with type t = A.t
+ This is actually:
+ module type Functor = (SetLike => Set) with type t = A.t
+ *)
+ let modTypeWithOperand modType = match modType with
+ | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true
+ | _ -> false
+
+ let modExprFunctorConstraint modType = match modType with
+ | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true
+ | _ -> false
+
+ let bracedExpr expr = match expr.Parsetree.pexp_desc with
+ | Pexp_constraint (
+ {pexp_desc = Pexp_pack _},
+ {ptyp_desc = Ptyp_package _}
+ ) -> false
+ | Pexp_constraint _ -> true
+ | _ -> false
+
+ let includeModExpr modExpr = match modExpr.Parsetree.pmod_desc with
+ | Parsetree.Pmod_constraint _ -> true
+ | _ -> false
+
+let arrowReturnTypExpr typExpr = match typExpr.Parsetree.ptyp_desc with
+ | Parsetree.Ptyp_arrow _ -> true
+ | _ -> false
+
+let patternRecordRowRhs (pattern : Parsetree.pattern) =
+ match pattern.ppat_desc with
+ | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) -> false
+ | Ppat_constraint _ -> true
+ | _ -> false
diff --git a/jscomp/napkin/res_parens.mli b/jscomp/napkin/res_parens.mli
new file mode 100644
index 0000000000..095b563089
--- /dev/null
+++ b/jscomp/napkin/res_parens.mli
@@ -0,0 +1,36 @@
+type kind = Parenthesized | Braced of Location.t | Nothing
+
+val expr: Parsetree.expression -> kind
+val structureExpr: Parsetree.expression -> kind
+
+val unaryExprOperand: Parsetree.expression -> kind
+
+val binaryExprOperand: isLhs:bool -> Parsetree.expression -> kind
+val subBinaryExprOperand: string -> string -> bool
+val rhsBinaryExprOperand: string -> Parsetree.expression -> bool
+val flattenOperandRhs: string -> Parsetree.expression -> bool
+
+val lazyOrAssertExprRhs: Parsetree.expression -> kind
+
+val fieldExpr: Parsetree.expression -> kind
+
+val setFieldExprRhs: Parsetree.expression -> kind
+
+val ternaryOperand: Parsetree.expression -> kind
+
+val jsxPropExpr: Parsetree.expression -> kind
+val jsxChildExpr: Parsetree.expression -> kind
+
+val binaryExpr: Parsetree.expression -> kind
+val modTypeFunctorReturn: Parsetree.module_type -> bool
+val modTypeWithOperand: Parsetree.module_type -> bool
+val modExprFunctorConstraint: Parsetree.module_type -> bool
+
+val bracedExpr: Parsetree.expression -> bool
+val callExpr: Parsetree.expression -> kind
+
+val includeModExpr : Parsetree.module_expr -> bool
+
+val arrowReturnTypExpr: Parsetree.core_type -> bool
+
+val patternRecordRowRhs: Parsetree.pattern -> bool
diff --git a/jscomp/napkin/res_parser.ml b/jscomp/napkin/res_parser.ml
new file mode 100644
index 0000000000..6aa63f97f2
--- /dev/null
+++ b/jscomp/napkin/res_parser.ml
@@ -0,0 +1,163 @@
+module Scanner = Res_scanner
+module Diagnostics = Res_diagnostics
+module Token = Res_token
+module Grammar = Res_grammar
+module Reporting = Res_reporting
+
+module Comment = Res_comment
+
+type mode = ParseForTypeChecker | Default
+
+type regionStatus = Report | Silent
+
+type t = {
+ mode: mode;
+ mutable scanner: Scanner.t;
+ mutable token: Token.t;
+ mutable startPos: Lexing.position;
+ mutable endPos: Lexing.position;
+ mutable prevEndPos: Lexing.position;
+ mutable breadcrumbs: (Grammar.t * Lexing.position) list;
+ mutable errors: Reporting.parseError list;
+ mutable diagnostics: Diagnostics.t list;
+ mutable comments: Comment.t list;
+ mutable regions: regionStatus ref list;
+}
+
+let err ?startPos ?endPos p error =
+ match p.regions with
+ | {contents = Report} as region::_ ->
+ let d =
+ Diagnostics.make
+ ~startPos:(match startPos with | Some pos -> pos | None -> p.startPos)
+ ~endPos:(match endPos with | Some pos -> pos | None -> p.endPos)
+ error
+ in (
+ p.diagnostics <- d::p.diagnostics;
+ region := Silent
+ )
+ | _ -> ()
+
+let beginRegion p =
+ p.regions <- ref Report :: p.regions
+let endRegion p =
+ match p.regions with
+ | [] -> ()
+ | _::rest -> p.regions <- rest
+
+(* Advance to the next non-comment token and store any encountered comment
+* in the parser's state. Every comment contains the end position of its
+* previous token to facilite comment interleaving *)
+let rec next ?prevEndPos p =
+ let prevEndPos = match prevEndPos with Some pos -> pos | None -> p.endPos in
+ let (startPos, endPos, token) = Scanner.scan p.scanner in
+ match token with
+ | Comment c ->
+ Comment.setPrevTokEndPos c p.endPos;
+ p.comments <- c::p.comments;
+ p.prevEndPos <- p.endPos;
+ p.endPos <- endPos;
+ next ~prevEndPos p
+ | _ ->
+ p.token <- token;
+ (* p.prevEndPos <- prevEndPos; *)
+ p.prevEndPos <- prevEndPos;
+ p.startPos <- startPos;
+ p.endPos <- endPos
+
+let nextTemplateLiteralToken p =
+ let (startPos, endPos, token) = Scanner.scanTemplateLiteralToken p.scanner in
+ p.token <- token;
+ p.prevEndPos <- p.endPos;
+ p.startPos <- startPos;
+ p.endPos <- endPos
+
+let checkProgress ~prevEndPos ~result p =
+ if p.endPos == prevEndPos
+ then None
+ else Some result
+
+let make ?(mode=ParseForTypeChecker) src filename =
+ let scanner = Scanner.make ~filename src in
+ let parserState = {
+ mode;
+ scanner;
+ token = Token.Eof;
+ startPos = Lexing.dummy_pos;
+ prevEndPos = Lexing.dummy_pos;
+ endPos = Lexing.dummy_pos;
+ breadcrumbs = [];
+ errors = [];
+ diagnostics = [];
+ comments = [];
+ regions = [ref Report];
+ } in
+ parserState.scanner.err <- (fun ~startPos ~endPos error ->
+ let diagnostic = Diagnostics.make
+ ~startPos
+ ~endPos
+ error
+ in
+ parserState.diagnostics <- diagnostic::parserState.diagnostics
+ );
+ next parserState;
+ parserState
+
+let leaveBreadcrumb p circumstance =
+ let crumb = (circumstance, p.startPos) in
+ p.breadcrumbs <- crumb::p.breadcrumbs
+
+let eatBreadcrumb p =
+ match p.breadcrumbs with
+ | [] -> ()
+ | _::crumbs -> p.breadcrumbs <- crumbs
+
+let optional p token =
+ if p.token = token then
+ let () = next p in true
+ else
+ false
+
+let expect ?grammar token p =
+ if p.token = token then
+ next p
+ else
+ let error = Diagnostics.expected ?grammar p.prevEndPos token in
+ err ~startPos:p.prevEndPos p error
+
+(* Don't use immutable copies here, it trashes certain heuristics
+ * in the ocaml compiler, resulting in massive slowdowns of the parser *)
+let lookahead p callback =
+ let err = p.scanner.err in
+ let ch = p.scanner.ch in
+ let offset = p.scanner.offset in
+ let lineOffset = p.scanner.lineOffset in
+ let lnum = p.scanner.lnum in
+ let mode = p.scanner.mode in
+ let token = p.token in
+ let startPos = p.startPos in
+ let endPos = p.endPos in
+ let prevEndPos = p.prevEndPos in
+ let breadcrumbs = p.breadcrumbs in
+ let errors = p.errors in
+ let diagnostics = p.diagnostics in
+ let comments = p.comments in
+
+ let res = callback p in
+
+ p.scanner.err <- err;
+ p.scanner.ch <- ch;
+ p.scanner.offset <- offset;
+ p.scanner.lineOffset <- lineOffset;
+ p.scanner.lnum <- lnum;
+ p.scanner.mode <- mode;
+ p.token <- token;
+ p.startPos <- startPos;
+ p.endPos <- endPos;
+ p.prevEndPos <- prevEndPos;
+ p.breadcrumbs <- breadcrumbs;
+ p.errors <- errors;
+ p.diagnostics <- diagnostics;
+ p.comments <- comments;
+
+ res
diff --git a/jscomp/napkin/res_parser.mli b/jscomp/napkin/res_parser.mli
new file mode 100644
index 0000000000..80a1c6394a
--- /dev/null
+++ b/jscomp/napkin/res_parser.mli
@@ -0,0 +1,48 @@
+module Scanner = Res_scanner
+module Token = Res_token
+module Grammar = Res_grammar
+module Reporting = Res_reporting
+module Diagnostics = Res_diagnostics
+module Comment = Res_comment
+
+type mode = ParseForTypeChecker | Default
+
+type regionStatus = Report | Silent
+
+type t = {
+ mode: mode;
+ mutable scanner: Scanner.t;
+ mutable token: Token.t;
+ mutable startPos: Lexing.position;
+ mutable endPos: Lexing.position;
+ mutable prevEndPos: Lexing.position;
+ mutable breadcrumbs: (Grammar.t * Lexing.position) list;
+ mutable errors: Reporting.parseError list;
+ mutable diagnostics: Diagnostics.t list;
+ mutable comments: Comment.t list;
+ mutable regions: regionStatus ref list;
+}
+
+val make: ?mode:mode -> string -> string -> t
+
+val expect: ?grammar:Grammar.t -> Token.t -> t -> unit
+val optional: t -> Token.t -> bool
+val next: ?prevEndPos:Lexing.position -> t -> unit
+val nextTemplateLiteralToken: t -> unit
+val lookahead: t -> (t -> 'a) -> 'a
+val err:
+ ?startPos:Lexing.position ->
+ ?endPos:Lexing.position ->
+ t -> Diagnostics.category -> unit
+
+val leaveBreadcrumb: t -> Grammar.t -> unit
+val eatBreadcrumb: t -> unit
+
+val beginRegion: t -> unit
+val endRegion: t -> unit
+
+val checkProgress:
+ prevEndPos: Lexing.position ->
+ result: 'a ->
+ t ->
+ 'a option
diff --git a/jscomp/napkin/res_parsetree_viewer.ml b/jscomp/napkin/res_parsetree_viewer.ml
new file mode 100644
index 0000000000..3bb2da3d50
--- /dev/null
+++ b/jscomp/napkin/res_parsetree_viewer.ml
@@ -0,0 +1,578 @@
+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" | "res.template" | "bs" | "ns.iflet" | "ns.namedArgLoc")}, _) -> false
+ | _ -> true
+ ) attrs
+
+let isBlockExpr expr =
+ match expr.pexp_desc with
+ | Pexp_letmodule _
+ | Pexp_letexception _
+ | Pexp_let _
+ | Pexp_open _
+ | Pexp_sequence _ -> true
+ | _ -> false
+
+let isBracedExpr expr =
+ match processBracesAttr expr with
+ | (Some _, _) -> true
+ | _ -> false
+
+let isMultilineText txt =
+ let len = String.length txt in
+ let rec check i=
+ if i >= len then false
+ else
+ let c = String.unsafe_get txt i in
+ match c with
+ | '\010' | '\013' -> true
+ | '\\' ->
+ if (i + 2) = len then false
+ else
+ check (i + 2)
+ | _ -> check (i + 1)
+ in
+ check 0
+
+let isHuggableExpression expr =
+ match expr.pexp_desc with
+ | Pexp_array _
+ | Pexp_tuple _
+ | Pexp_constant (Pconst_string (_, Some _))
+ | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _)
+ | Pexp_extension ({txt = "bs.obj" | "obj"}, _)
+ | Pexp_record _ -> true
+ | _ when isBlockExpr expr -> true
+ | _ when isBracedExpr expr -> true
+ | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true
+ | _ -> false
+
+let isHuggableRhs expr =
+ match expr.pexp_desc with
+ | Pexp_array _
+ | Pexp_tuple _
+ | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _)
+ | Pexp_extension ({txt = "bs.obj" | "obj"}, _)
+ | Pexp_record _ -> true
+ | _ when isBracedExpr expr -> true
+ | _ -> false
+
+let isHuggablePattern pattern =
+ match pattern.ppat_desc with
+ | Ppat_array _
+ | Ppat_tuple _
+ | Ppat_record _
+ | Ppat_variant _
+ | Ppat_construct _ -> true
+ | _ -> false
+
+let operatorPrecedence operator = match operator with
+ | ":=" -> 1
+ | "||" -> 2
+ | "&&" -> 3
+ | "=" | "==" | "<" | ">" | "!=" | "<>" | "!==" | "<=" | ">=" | "|>" -> 4
+ | "+" | "+." | "-" | "-." | "^" -> 5
+ | "*" | "*." | "/" | "/." -> 6
+ | "**" -> 7
+ | "#" | "##" | "|." -> 8
+ | _ -> 0
+
+let isUnaryOperator operator = match operator with
+ | "~+" | "~+." | "~-" | "~-." | "not" -> true
+ | _ -> false
+
+let isUnaryExpression expr = match expr.pexp_desc with
+ | Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Longident.Lident operator}},
+ [Nolabel, _arg]
+ ) when isUnaryOperator operator -> true
+ | _ -> false
+
+(* TODO: tweak this to check for ghost ^ as template literal *)
+let isBinaryOperator operator = match operator with
+ | ":="
+ | "||"
+ | "&&"
+ | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>"
+ | "+" | "+." | "-" | "-." | "^"
+ | "*" | "*." | "/" | "/."
+ | "**"
+ | "|." | "<>" -> true
+ | _ -> false
+
+let isBinaryExpression expr = match expr.pexp_desc with
+ | Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}},
+ [(Nolabel, _operand1); (Nolabel, _operand2)]
+ ) when isBinaryOperator operator &&
+ not (operatorLoc.loc_ghost && operator = "^") (* template literal *)
+ -> true
+ | _ -> false
+
+let isEqualityOperator operator = match operator with
+ | "=" | "==" | "<>" | "!=" -> true
+ | _ -> false
+
+let flattenableOperators parentOperator childOperator =
+ let precParent = operatorPrecedence parentOperator in
+ let precChild = operatorPrecedence childOperator in
+ if precParent == precChild then
+ not (
+ isEqualityOperator parentOperator &&
+ isEqualityOperator childOperator
+ )
+ else
+ false
+
+let rec hasIfLetAttribute attrs =
+ match attrs with
+ | [] -> false
+ | ({Location.txt="ns.iflet"},_)::_ -> true
+ | _::attrs -> hasIfLetAttribute attrs
+
+let isIfLetExpr expr = match expr with
+ | {
+ pexp_attributes = attrs;
+ pexp_desc = Pexp_match _
+ } when hasIfLetAttribute attrs -> true
+ | _ -> false
+
+let hasAttributes attrs =
+ List.exists (fun attr -> match attr with
+ | ({Location.txt = "bs" | "res.template" | "ns.ternary" | "ns.braces" | "ns.iflet"}, _) -> false
+ (* Remove the fragile pattern warning for iflet expressions *)
+ | ({Location.txt="warning"}, PStr [{
+ pstr_desc = Pstr_eval ({
+ pexp_desc = Pexp_constant (
+ Pconst_string ("-4", None)
+ )
+ }, _)
+ }]) -> not (hasIfLetAttribute attrs)
+ | _ -> true
+ ) attrs
+
+let isArrayAccess expr = match expr.pexp_desc with
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}},
+ [Nolabel, _parentExpr; Nolabel, _memberExpr]
+ ) -> true
+ | _ -> false
+
+
+type ifConditionKind =
+| If of Parsetree.expression
+| IfLet of Parsetree.pattern * Parsetree.expression
+
+let collectIfExpressions expr =
+ let rec collect acc expr = match expr.pexp_desc with
+ | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) ->
+ collect ((If(ifExpr), thenExpr)::acc) elseExpr
+ | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) ->
+ let ifs = List.rev ((If(ifExpr), thenExpr)::acc) in
+ (ifs, elseExpr)
+ | Pexp_match (condition, [{
+ pc_lhs = pattern;
+ pc_guard = None;
+ pc_rhs = thenExpr;
+ }; {
+ pc_rhs = {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}
+ }]) when isIfLetExpr expr ->
+ let ifs = List.rev ((IfLet(pattern, condition), thenExpr)::acc) in
+ (ifs, None)
+ | Pexp_match (condition, [{
+ pc_lhs = pattern;
+ pc_guard = None;
+ pc_rhs = thenExpr;
+ }; {
+ pc_rhs = elseExpr;
+ }]) when isIfLetExpr expr ->
+ collect ((IfLet(pattern, condition), thenExpr)::acc) elseExpr
+ | _ ->
+ (List.rev acc, Some expr)
+ in
+ collect [] expr
+
+let rec hasTernaryAttribute attrs =
+ match attrs with
+ | [] -> false
+ | ({Location.txt="ns.ternary"},_)::_ -> true
+ | _::attrs -> hasTernaryAttribute attrs
+
+let isTernaryExpr expr = match expr with
+ | {
+ pexp_attributes = attrs;
+ pexp_desc = Pexp_ifthenelse _
+ } when hasTernaryAttribute attrs -> true
+ | _ -> false
+
+let collectTernaryParts expr =
+ let rec collect acc expr = match expr with
+ | {
+ pexp_attributes = attrs;
+ pexp_desc = Pexp_ifthenelse (condition, consequent, Some(alternate))
+ } when hasTernaryAttribute attrs -> collect ((condition, consequent)::acc) alternate
+ | alternate -> (List.rev acc, alternate)
+ in
+ collect [] expr
+
+let parametersShouldHug parameters = match parameters with
+ | [Parameter {
+ attrs = [];
+ lbl = Asttypes.Nolabel;
+ defaultExpr = None;
+ pat = pat
+ }] when isHuggablePattern pat -> true
+ | _ -> false
+
+let filterTernaryAttributes attrs =
+ List.filter (fun attr -> match attr with
+ |({Location.txt="ns.ternary"},_) -> false
+ | _ -> true
+ ) attrs
+
+let filterFragileMatchAttributes attrs =
+ List.filter (fun attr -> match attr with
+ | ({Location.txt="warning"}, PStr [{
+ pstr_desc = Pstr_eval ({
+ pexp_desc = Pexp_constant (
+ Pconst_string ("-4", _)
+ )
+ }, _)
+ }]) -> false
+ | _ -> true
+ ) attrs
+
+let isJsxExpression expr =
+ let rec loop attrs =
+ match attrs with
+ | [] -> false
+ | ({Location.txt = "JSX"}, _)::_ -> true
+ | _::attrs -> loop attrs
+ in
+ match expr.pexp_desc with
+ | Pexp_apply _ ->
+ loop expr.Parsetree.pexp_attributes
+ | _ -> false
+
+let hasJsxAttribute attributes =
+ let rec loop attrs =
+ match attrs with
+ | [] -> false
+ | ({Location.txt = "JSX"}, _)::_ -> true
+ | _::attrs -> loop attrs
+ in
+ loop attributes
+
+let shouldIndentBinaryExpr expr =
+ let samePrecedenceSubExpression operator subExpression =
+ match subExpression with
+ | {pexp_desc = Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}},
+ [Nolabel, _lhs; Nolabel, _rhs]
+ )} when isBinaryOperator subOperator ->
+ flattenableOperators operator subOperator
+ | _ -> true
+ in
+ match expr with
+ | {pexp_desc = Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident operator}},
+ [Nolabel, lhs; Nolabel, _rhs]
+ )} when isBinaryOperator operator ->
+ isEqualityOperator operator ||
+ not (samePrecedenceSubExpression operator lhs) ||
+ operator = ":="
+ | _ -> false
+
+let shouldInlineRhsBinaryExpr rhs = match rhs.pexp_desc with
+ | Parsetree.Pexp_constant _
+ | Pexp_let _
+ | Pexp_letmodule _
+ | Pexp_letexception _
+ | Pexp_sequence _
+ | Pexp_open _
+ | Pexp_ifthenelse _
+ | Pexp_for _
+ | Pexp_while _
+ | Pexp_try _
+ | Pexp_array _
+ | Pexp_record _ -> true
+ | _ -> false
+
+let filterPrinteableAttributes attrs =
+ List.filter (fun attr -> match attr with
+ | ({Location.txt="bs" | "res.template" | "ns.ternary" | "ns.iflet" | "JSX"}, _) -> false
+ | _ -> true
+ ) attrs
+
+let partitionPrinteableAttributes attrs =
+ List.partition (fun attr -> match attr with
+ | ({Location.txt="bs" | "res.template"| "ns.ternary" | "ns.iflet" | "JSX"}, _) -> false
+ | _ -> true
+ ) attrs
+
+let requiresSpecialCallbackPrintingLastArg args =
+ let rec loop args = match args with
+ | [] -> false
+ | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true
+ | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false
+ | _::rest -> loop rest
+ in
+ loop args
+
+let requiresSpecialCallbackPrintingFirstArg args =
+ let rec loop args = match args with
+ | [] -> true
+ | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false
+ | _::rest -> loop rest
+ in
+ match args with
+ | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false
+ | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::rest -> loop rest
+ | _ -> false
+
+let modExprApply modExpr =
+ let rec loop acc modExpr = match modExpr with
+ | {pmod_desc = Pmod_apply (next, arg)} ->
+ loop (arg::acc) next
+ | _ -> (acc, modExpr)
+ in
+ loop [] modExpr
+
+let modExprFunctor modExpr =
+ let rec loop acc modExpr = match modExpr with
+ | {pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} ->
+ let param = (attrs, lbl, modType) in
+ loop (param::acc) returnModExpr
+ | returnModExpr ->
+ (List.rev acc, returnModExpr)
+ in
+ loop [] modExpr
+
+let rec collectPatternsFromListConstruct acc pattern =
+ let open Parsetree in
+ match pattern.ppat_desc with
+ | Ppat_construct(
+ {txt = Longident.Lident "::"},
+ Some {ppat_desc=Ppat_tuple (pat::rest::[])}
+ ) ->
+ collectPatternsFromListConstruct (pat::acc) rest
+ | _ -> List.rev acc, pattern
+
+
+let hasTemplateLiteralAttr attrs = List.exists (fun attr -> match attr with
+| ({Location.txt = "res.template"}, _) -> true
+| _ -> false) attrs
+
+let isTemplateLiteral expr =
+ match expr.pexp_desc with
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}},
+ [Nolabel, _; Nolabel, _]
+ ) when hasTemplateLiteralAttr expr.pexp_attributes -> true
+ | Pexp_constant (Pconst_string (_, Some "")) -> true
+ | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true
+ | _ -> false
+
+(* Blue | Red | Green -> [Blue; Red; Green] *)
+let collectOrPatternChain pat =
+ let rec loop pattern chain =
+ match pattern.ppat_desc with
+ | Ppat_or (left, right) -> loop left (right::chain)
+ | _ -> pattern::chain
+ in
+ loop pat []
+
+let isSinglePipeExpr expr =
+ (* handles:
+ * x
+ * ->Js.Dict.get("wm-property")
+ * ->Option.flatMap(Js.Json.decodeString)
+ * ->Option.flatMap(x =>
+ * switch x {
+ * | "like-of" => Some(#like)
+ * | "repost-of" => Some(#repost)
+ * | _ => None
+ * }
+ * )
+ *)
+ let isPipeExpr expr = match expr.pexp_desc with
+ | Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }},
+ [(Nolabel, _operand1); (Nolabel, _operand2)]
+ ) -> true
+ | _ -> false
+ in
+ match expr.pexp_desc with
+ | Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }},
+ [(Nolabel, operand1); (Nolabel, _operand2)]
+ ) when not (isPipeExpr operand1) -> true
+ | _ -> false
+
+let isUnderscoreApplySugar expr =
+ match expr.pexp_desc with
+ | Pexp_fun (
+ Nolabel,
+ None,
+ {ppat_desc = Ppat_var {txt="__x"}},
+ {pexp_desc = Pexp_apply _}
+ ) -> true
+ | _ -> false
+
+let isRewrittenUnderscoreApplySugar expr =
+ match expr.pexp_desc with
+ | Pexp_ident {txt = Longident.Lident "_"} -> true
+ | _ -> false
diff --git a/jscomp/napkin/res_parsetree_viewer.mli b/jscomp/napkin/res_parsetree_viewer.mli
new file mode 100644
index 0000000000..65a673679d
--- /dev/null
+++ b/jscomp/napkin/res_parsetree_viewer.mli
@@ -0,0 +1,133 @@
+(* Restructures a nested tree of arrow types into its args & returnType
+ * The parsetree contains: a => b => c => d, for printing purposes
+ * we restructure the tree into (a, b, c) and its returnType d *)
+ val arrowType: Parsetree.core_type ->
+ Parsetree.attributes *
+ (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list *
+ Parsetree.core_type
+
+val functorType: Parsetree.module_type ->
+ (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list *
+ Parsetree.module_type
+
+(* filters @bs out of the provided attributes *)
+val processUncurriedAttribute: Parsetree.attributes -> bool * Parsetree.attributes
+
+type ifConditionKind =
+ | If of Parsetree.expression
+ | IfLet of Parsetree.pattern * Parsetree.expression
+
+(* if ... else if ... else ... is represented as nested expressions: if ... else { if ... }
+* The purpose of this function is to flatten nested ifs into one sequence.
+* Basically compute: ([if, else if, else if, else if], else) *)
+val collectIfExpressions:
+ Parsetree.expression ->
+ (ifConditionKind * Parsetree.expression) list * Parsetree.expression option
+
+val collectListExpressions:
+ Parsetree.expression -> (Parsetree.expression list * Parsetree.expression option)
+
+type funParamKind =
+ | Parameter of {
+ attrs: Parsetree.attributes;
+ lbl: Asttypes.arg_label;
+ defaultExpr: Parsetree.expression option;
+ pat: Parsetree.pattern;
+ }
+ | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list}
+
+val funExpr:
+ Parsetree.expression ->
+ Parsetree.attributes *
+ funParamKind list *
+ Parsetree.expression
+
+(* example:
+* `makeCoordinate({
+* x: 1,
+* y: 2,
+* })`
+* Notice howe `({` and `})` "hug" or stick to each other *)
+val isHuggableExpression: Parsetree.expression -> bool
+
+val isHuggablePattern: Parsetree.pattern -> bool
+
+val isHuggableRhs: Parsetree.expression -> bool
+
+val operatorPrecedence: string -> int
+
+val isUnaryExpression: Parsetree.expression -> bool
+val isBinaryOperator: string -> bool
+val isBinaryExpression: Parsetree.expression -> bool
+
+val flattenableOperators: string -> string -> bool
+
+val hasAttributes: Parsetree.attributes -> bool
+
+val isArrayAccess: Parsetree.expression -> bool
+val isTernaryExpr: Parsetree.expression -> bool
+val isIfLetExpr: Parsetree.expression -> bool
+
+val collectTernaryParts: Parsetree.expression -> ((Parsetree.expression * Parsetree.expression) list * Parsetree.expression)
+
+val parametersShouldHug:
+ funParamKind list -> bool
+
+val filterTernaryAttributes: Parsetree.attributes -> Parsetree.attributes
+val filterFragileMatchAttributes: Parsetree.attributes -> Parsetree.attributes
+
+val isJsxExpression: Parsetree.expression -> bool
+val hasJsxAttribute: Parsetree.attributes -> bool
+
+val shouldIndentBinaryExpr: Parsetree.expression -> bool
+val shouldInlineRhsBinaryExpr: Parsetree.expression -> bool
+val filterPrinteableAttributes: Parsetree.attributes -> Parsetree.attributes
+val partitionPrinteableAttributes: Parsetree.attributes -> (Parsetree.attributes * Parsetree.attributes)
+
+val requiresSpecialCallbackPrintingLastArg: (Asttypes.arg_label * Parsetree.expression) list -> bool
+val requiresSpecialCallbackPrintingFirstArg: (Asttypes.arg_label * Parsetree.expression) list -> bool
+
+val modExprApply : Parsetree.module_expr -> (
+ Parsetree.module_expr list * Parsetree.module_expr
+)
+
+(* Collection of utilities to view the ast in a more a convenient form,
+ * allowing for easier processing.
+ * Example: given a ptyp_arrow type, what are its arguments and what is the
+ * returnType? *)
+
+
+val modExprFunctor : Parsetree.module_expr -> (
+ (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list *
+ Parsetree.module_expr
+)
+
+val collectPatternsFromListConstruct:
+ Parsetree.pattern list -> Parsetree.pattern ->
+ (Parsetree.pattern list * Parsetree.pattern)
+
+val isBlockExpr : Parsetree.expression -> bool
+
+val isTemplateLiteral: Parsetree.expression -> bool
+val hasTemplateLiteralAttr: Parsetree.attributes -> bool
+
+val collectOrPatternChain:
+ Parsetree.pattern -> Parsetree.pattern list
+
+val processBracesAttr : Parsetree.expression -> (Parsetree.attribute option * Parsetree.expression)
+
+val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes
+
+val isBracedExpr : Parsetree.expression -> bool
+
+val isSinglePipeExpr : Parsetree.expression -> bool
+
+(* (__x) => f(a, __x, c) -----> f(a, _, c) *)
+val rewriteUnderscoreApply: Parsetree.expression -> Parsetree.expression
+
+(* (__x) => f(a, __x, c) -----> f(a, _, c) *)
+val isUnderscoreApplySugar: Parsetree.expression -> bool
+
+val hasIfLetAttribute: Parsetree.attributes -> bool
+
+val isRewrittenUnderscoreApplySugar: Parsetree.expression -> bool
diff --git a/jscomp/napkin/res_printer.ml b/jscomp/napkin/res_printer.ml
new file mode 100644
index 0000000000..42d2de77cd
--- /dev/null
+++ b/jscomp/napkin/res_printer.ml
@@ -0,0 +1,5280 @@
+module Doc = Res_doc
+module CommentTable = Res_comments_table
+module Comment = Res_comment
+module Token = Res_token
+module Parens = Res_parens
+module ParsetreeViewer = Res_parsetree_viewer
+
+type callbackStyle =
+ (* regular arrow function, example: `let f = x => x + 1` *)
+ | NoCallback
+ (* `Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument))` *)
+ | FitsOnOneLine
+ (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) =>
+ * MyModuleBlah.toList(argument)
+ * )
+ *)
+ | ArgumentsFitOnOneLine
+
+(* Since compiler version 8.3, the bs. prefix is no longer needed *)
+(* Synced from
+ https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_external_process.ml#L291-L367 *)
+let convertBsExternalAttribute = function
+ | "bs.as" -> "as"
+ | "bs.deriving" -> "deriving"
+ | "bs.get" -> "get"
+ | "bs.get_index" -> "get_index"
+ | "bs.ignore" -> "ignore"
+ | "bs.inline" -> "inline"
+ | "bs.int" -> "int"
+ | "bs.meth" -> "meth"
+ | "bs.module" -> "module"
+ | "bs.new" -> "new"
+ | "bs.obj" -> "obj"
+ | "bs.optional" -> "optional"
+ | "bs.return" -> "return"
+ | "bs.send" -> "send"
+ | "bs.scope" -> "scope"
+ | "bs.set" -> "set"
+ | "bs.set_index" -> "set_index"
+ | "bs.splice" | "bs.variadic" -> "variadic"
+ | "bs.string" -> "string"
+ | "bs.this" -> "this"
+ | "bs.uncurry" -> "uncurry"
+ | "bs.unwrap" -> "unwrap"
+ | "bs.val" -> "val"
+ (* bs.send.pipe shouldn't be transformed *)
+ | txt -> txt
+
+(* These haven't been needed for a long time now *)
+(* Synced from
+ https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_exp_extension.ml *)
+let convertBsExtension = function
+ | "bs.debugger" -> "debugger"
+ | "bs.external" -> "raw"
+ (* We should never see this one since we use the sugared object form, but still *)
+ | "bs.obj" -> "obj"
+ | "bs.raw" -> "raw"
+ | "bs.re" -> "re"
+ (* TODO: what about bs.time and bs.node? *)
+ | txt -> txt
+
+let addParens doc =
+ Doc.group (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ doc
+ ]
+ );
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+
+let addBraces doc =
+ Doc.group (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ doc;
+ ]
+ );
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+
+let getFirstLeadingComment tbl loc =
+ match Hashtbl.find tbl.CommentTable.leading loc with
+ | comment::_ -> Some comment
+ | [] -> None
+ | exception Not_found -> None
+
+(* Checks if `loc` has a leading line comment, i.e. `// comment above`*)
+let hasLeadingLineComment tbl loc =
+ match getFirstLeadingComment tbl loc with
+ | Some comment -> Comment.isSingleLineComment comment
+ | None -> false
+
+let hasCommentBelow tbl loc =
+ match Hashtbl.find tbl.CommentTable.trailing loc with
+ | comment::_ ->
+ let commentLoc = Comment.loc comment in
+ commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum
+ | [] -> false
+ | exception Not_found -> false
+
+let printMultilineCommentContent txt =
+ (* Turns
+ * |* first line
+ * * second line
+ * * third line *|
+ * Into
+ * |* first line
+ * * second line
+ * * third line *|
+ *
+ * What makes a comment suitable for this kind of indentation?
+ * -> multiple lines + every line starts with a star
+ *)
+ let rec indentStars lines acc =
+ match lines with
+ | [] -> Doc.nil
+ | [lastLine] ->
+ let line = String.trim lastLine in
+ let doc = Doc.text (" " ^ line) in
+ let trailingSpace = if line = "" then Doc.nil else Doc.space in
+ List.rev (trailingSpace::doc::acc) |> Doc.concat
+ | line::lines ->
+ let line = String.trim line in
+ if line != "" && String.unsafe_get line 0 == '*' then
+ let doc = Doc.text (" " ^ line) in
+ indentStars lines (Doc.hardLine::doc::acc)
+ else
+ let trailingSpace =
+ let len = String.length txt in
+ if len > 0 && (String.unsafe_get txt (len - 1) = ' ') then
+ Doc.space
+ else Doc.nil
+ in
+ let content = Comment.trimSpaces txt in
+ Doc.concat [Doc.text content; trailingSpace]
+ in
+ let lines = String.split_on_char '\n' txt in
+ match lines with
+ | [] -> Doc.text "/* */"
+ | [line] -> Doc.concat [
+ Doc.text "/* ";
+ Doc.text (Comment.trimSpaces line);
+ Doc.text " */";
+ ]
+ | first::rest ->
+ let firstLine = Comment.trimSpaces first in
+ Doc.concat [
+ Doc.text "/*";
+ (match firstLine with
+ | "" | "*" -> Doc.nil
+ | _ -> Doc.space);
+ indentStars rest [Doc.hardLine; Doc.text firstLine];
+ Doc.text "*/";
+ ]
+
+let printTrailingComment (prevLoc: Location.t) (nodeLoc : Location.t) comment =
+ let singleLine = Comment.isSingleLineComment comment in
+ let content =
+ let txt = Comment.txt comment in
+ if singleLine then
+ Doc.text ("//" ^ txt)
+ else
+ printMultilineCommentContent txt
+ in
+ let diff =
+ let cmtStart = (Comment.loc comment).loc_start in
+ cmtStart.pos_lnum - prevLoc.loc_end.pos_lnum
+ in
+ let isBelow =
+ (Comment.loc comment).loc_start.pos_lnum > nodeLoc.loc_end.pos_lnum in
+ if diff > 0 || isBelow then
+ Doc.concat [
+ Doc.breakParent;
+ Doc.lineSuffix(
+ (Doc.concat [Doc.hardLine; if diff > 1 then Doc.hardLine else Doc.nil; content])
+ )
+ ]
+ else if not singleLine then
+ Doc.concat [Doc.space; content]
+ else
+ Doc.lineSuffix (Doc.concat [Doc.space; content])
+
+let printLeadingComment ?nextComment comment =
+ let singleLine = Comment.isSingleLineComment comment in
+ let content =
+ let txt = Comment.txt comment in
+ if singleLine then
+ Doc.text ("//" ^ txt)
+ else
+ printMultilineCommentContent txt
+ in
+ let separator = Doc.concat [
+ if singleLine then Doc.concat [
+ Doc.hardLine;
+ Doc.breakParent;
+ ] else Doc.nil;
+ (match nextComment with
+ | Some next ->
+ let nextLoc = Comment.loc next in
+ let currLoc = Comment.loc comment in
+ let diff =
+ nextLoc.Location.loc_start.pos_lnum -
+ currLoc.Location.loc_end.pos_lnum
+ in
+ let nextSingleLine = Comment.isSingleLineComment next in
+ if singleLine && nextSingleLine then
+ if diff > 1 then Doc.hardLine else Doc.nil
+ else if singleLine && not nextSingleLine then
+ if diff > 1 then Doc.hardLine else Doc.nil
+ else
+ if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine]
+ else if diff == 1 then Doc.hardLine
+ else
+ Doc.space
+ | None -> Doc.nil)
+ ]
+ in
+ Doc.concat [
+ content;
+ separator;
+ ]
+
+let printCommentsInside cmtTbl loc =
+ let rec loop acc comments =
+ match comments with
+ | [] -> Doc.nil
+ | [comment] ->
+ let cmtDoc = printLeadingComment comment in
+ let doc = Doc.group (
+ Doc.concat [
+ Doc.concat (List.rev (cmtDoc::acc));
+ ]
+ )
+ in
+ doc
+ | comment::((nextComment::_comments) as rest) ->
+ let cmtDoc = printLeadingComment ~nextComment comment in
+ loop (cmtDoc::acc) rest
+ in
+ match Hashtbl.find cmtTbl.CommentTable.inside loc with
+ | exception Not_found -> Doc.nil
+ | comments ->
+ Hashtbl.remove cmtTbl.inside loc;
+ Doc.group (
+ loop [] comments
+ )
+
+let printLeadingComments node tbl loc =
+ let rec loop acc comments =
+ match comments with
+ | [] -> node
+ | [comment] ->
+ let cmtDoc = printLeadingComment comment in
+ let diff =
+ loc.Location.loc_start.pos_lnum -
+ (Comment.loc comment).Location.loc_end.pos_lnum
+ in
+ let separator =
+ if Comment.isSingleLineComment comment then
+ if diff > 1 then Doc.hardLine else Doc.nil
+ else if diff == 0 then
+ Doc.space
+ else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine]
+ else
+ Doc.hardLine
+ in
+ let doc = Doc.group (
+ Doc.concat [
+ Doc.concat (List.rev (cmtDoc::acc));
+ separator;
+ node
+ ]
+ )
+ in
+ doc
+ | comment::((nextComment::_comments) as rest) ->
+ let cmtDoc = printLeadingComment ~nextComment comment in
+ loop (cmtDoc::acc) rest
+ in
+ match Hashtbl.find tbl loc with
+ | exception Not_found -> node
+ | comments ->
+ (* Remove comments from tbl: Some ast nodes have the same location.
+ * We only want to print comments once *)
+ Hashtbl.remove tbl loc;
+ loop [] comments
+
+let printTrailingComments node tbl loc =
+ let rec loop prev acc comments =
+ match comments with
+ | [] -> Doc.concat (List.rev acc)
+ | comment::comments ->
+ let cmtDoc = printTrailingComment prev loc comment in
+ loop (Comment.loc comment) (cmtDoc::acc) comments
+ in
+ match Hashtbl.find tbl loc with
+ | exception Not_found -> node
+ | [] -> node
+ | (_first::_) as comments ->
+ (* Remove comments from tbl: Some ast nodes have the same location.
+ * We only want to print comments once *)
+ Hashtbl.remove tbl loc;
+ let cmtsDoc = loop loc [] comments in
+ Doc.concat [
+ node;
+ cmtsDoc;
+ ]
+
+let printComments doc (tbl: CommentTable.t) loc =
+ let docWithLeadingComments = printLeadingComments doc tbl.leading loc in
+ printTrailingComments docWithLeadingComments tbl.trailing loc
+
+let printList ~getLoc ~nodes ~print ?(forceBreak=false) t =
+ let rec loop (prevLoc: Location.t) acc nodes =
+ match nodes with
+ | [] -> (prevLoc, Doc.concat (List.rev acc))
+ | node::nodes ->
+ let loc = getLoc node in
+ let startPos = match getFirstLeadingComment t loc with
+ | None -> loc.loc_start
+ | Some comment -> (Comment.loc comment).loc_start
+ in
+ let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then
+ Doc.concat [Doc.hardLine; Doc.hardLine]
+ else
+ Doc.hardLine
+ in
+ let doc = printComments (print node t) t loc in
+ loop loc (doc::sep::acc) nodes
+ in
+ match nodes with
+ | [] -> Doc.nil
+ | node::nodes ->
+ let firstLoc = getLoc node in
+ let doc = printComments (print node t) t firstLoc in
+ let (lastLoc, docs) = loop firstLoc [doc] nodes in
+ let forceBreak =
+ forceBreak ||
+ firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum
+ in
+ Doc.breakableGroup ~forceBreak docs
+
+let printListi ~getLoc ~nodes ~print ?(forceBreak=false) t =
+ let rec loop i (prevLoc: Location.t) acc nodes =
+ match nodes with
+ | [] -> (prevLoc, Doc.concat (List.rev acc))
+ | node::nodes ->
+ let loc = getLoc node in
+ let startPos = match getFirstLeadingComment t loc with
+ | None -> loc.loc_start
+ | Some comment -> (Comment.loc comment).loc_start
+ in
+ let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then
+ Doc.concat [Doc.hardLine; Doc.hardLine]
+ else
+ Doc.line
+ in
+ let doc = printComments (print node t i) t loc in
+ loop (i + 1) loc (doc::sep::acc) nodes
+ in
+ match nodes with
+ | [] -> Doc.nil
+ | node::nodes ->
+ let firstLoc = getLoc node in
+ let doc = printComments (print node t 0) t firstLoc in
+ let (lastLoc, docs) = loop 1 firstLoc [doc] nodes in
+ let forceBreak =
+ forceBreak ||
+ firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum
+ in
+ Doc.breakableGroup ~forceBreak docs
+
+let rec printLongidentAux accu = function
+| Longident.Lident s -> (Doc.text s) :: accu
+| Ldot(lid, s) -> printLongidentAux ((Doc.text s) :: accu) lid
+| Lapply(lid1, lid2) ->
+ let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in
+ let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in
+ (Doc.concat [d1; Doc.lparen; d2; Doc.rparen]) :: accu
+
+let printLongident = function
+| Longident.Lident txt -> Doc.text txt
+| lid -> Doc.join ~sep:Doc.dot (printLongidentAux [] lid)
+
+type identifierStyle =
+ | ExoticIdent
+ | NormalIdent
+
+let classifyIdentContent ?(allowUident=false) txt =
+ if Token.isKeywordTxt txt then
+ ExoticIdent
+ else
+ let len = String.length txt in
+ let rec loop i =
+ if i == len then NormalIdent
+ else if i == 0 then
+ match String.unsafe_get txt i with
+ | 'A'..'Z' when allowUident -> loop (i + 1)
+ | 'a'..'z' | '_' -> loop (i + 1)
+ | _ -> ExoticIdent
+ else
+ match String.unsafe_get txt i with
+ | 'A'..'Z' | 'a'..'z' | '0'..'9' | '\'' | '_' -> loop (i + 1)
+ | _ -> ExoticIdent
+ in
+ loop 0
+
+let printIdentLike ?allowUident txt =
+ match classifyIdentContent ?allowUident txt with
+ | ExoticIdent -> Doc.concat [
+ Doc.text "\\\"";
+ Doc.text txt;
+ Doc.text"\""
+ ]
+ | NormalIdent -> Doc.text txt
+
+let rec unsafe_for_all_range s ~start ~finish p =
+ start > finish ||
+ p (String.unsafe_get s start) &&
+ unsafe_for_all_range s ~start:(start + 1) ~finish p
+
+let for_all_from s start p =
+ let len = String.length s in
+ unsafe_for_all_range s ~start ~finish:(len - 1) p
+
+(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *)
+let isValidNumericPolyvarNumber (x : string) =
+ let len = String.length x in
+ len > 0 && (
+ let a = Char.code (String.unsafe_get x 0) in
+ a <= 57 &&
+ (if len > 1 then
+ a > 48 &&
+ for_all_from x 1 (function '0' .. '9' -> true | _ -> false)
+ else
+ a >= 48 )
+ )
+
+(* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *)
+let printPolyVarIdent txt =
+ (* numeric poly-vars don't need quotes: #644 *)
+ if isValidNumericPolyvarNumber txt then
+ Doc.text txt
+ else
+ match classifyIdentContent ~allowUident:true txt with
+ | ExoticIdent -> Doc.concat [
+ Doc.text "\"";
+ Doc.text txt;
+ Doc.text"\""
+ ]
+ | NormalIdent -> Doc.text txt
+
+
+let printLident l = match l with
+ | Longident.Lident txt -> printIdentLike txt
+ | Longident.Ldot (path, txt) ->
+ let txts = Longident.flatten path in
+ Doc.concat [
+ Doc.join ~sep:Doc.dot (List.map Doc.text txts);
+ Doc.dot;
+ printIdentLike txt;
+ ]
+ | _ -> Doc.text("printLident: Longident.Lapply is not supported")
+
+let printLongidentLocation l cmtTbl =
+ let doc = printLongident l.Location.txt in
+ printComments doc cmtTbl l.loc
+
+(* Module.SubModule.x *)
+let printLidentPath path cmtTbl =
+ let doc = printLident path.Location.txt in
+ printComments doc cmtTbl path.loc
+
+(* Module.SubModule.x or Module.SubModule.X *)
+let printIdentPath path cmtTbl =
+ let doc = printLident path.Location.txt in
+ printComments doc cmtTbl path.loc
+
+let printStringLoc sloc cmtTbl =
+ let doc = printIdentLike sloc.Location.txt in
+ printComments doc cmtTbl sloc.loc
+
+let printStringContents txt =
+ let lines = String.split_on_char '\n' txt in
+ Doc.join ~sep:Doc.literalLine (List.map Doc.text lines)
+
+let printConstant ?(templateLiteral=false) c = match c with
+ | Parsetree.Pconst_integer (s, suffix) ->
+ begin match suffix with
+ | Some c -> Doc.text (s ^ (Char.escaped c))
+ | None -> Doc.text s
+ end
+ | Pconst_string (txt, None) ->
+ Doc.concat [
+ Doc.text "\"";
+ printStringContents txt;
+ Doc.text "\"";
+ ]
+ | Pconst_string (txt, Some prefix) ->
+ if prefix = "INTERNAL_RES_CHAR_CONTENTS" then
+ Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"]
+ else
+ let (lquote, rquote) =
+ if templateLiteral then ("`", "`") else ("\"", "\"")
+ in
+ Doc.concat [
+ if prefix = "js" then Doc.nil else Doc.text prefix;
+ Doc.text lquote;
+ printStringContents txt;
+ Doc.text rquote;
+ ]
+ | Pconst_float (s, _) -> Doc.text s
+ | Pconst_char c ->
+ let str = match c with
+ | '\'' -> "\\'"
+ | '\\' -> "\\\\"
+ | '\n' -> "\\n"
+ | '\t' -> "\\t"
+ | '\r' -> "\\r"
+ | '\b' -> "\\b"
+ | ' ' .. '~' as c ->
+ let s = (Bytes.create [@doesNotRaise]) 1 in
+ Bytes.unsafe_set s 0 c;
+ Bytes.unsafe_to_string s
+ | c ->
+ Res_utf8.encodeCodePoint (Obj.magic c)
+ in
+ Doc.text ("'" ^ str ^ "'")
+
+let rec printStructure (s : Parsetree.structure) t =
+ match s with
+ | [] -> printCommentsInside t Location.none
+ | structure ->
+ printList
+ ~getLoc:(fun s -> s.Parsetree.pstr_loc)
+ ~nodes:structure
+ ~print:printStructureItem
+ t
+
+and printStructureItem (si: Parsetree.structure_item) cmtTbl =
+ match si.pstr_desc with
+ | Pstr_value(rec_flag, valueBindings) ->
+ let recFlag = match rec_flag with
+ | Asttypes.Nonrecursive -> Doc.nil
+ | Asttypes.Recursive -> Doc.text "rec "
+ in
+ printValueBindings ~recFlag valueBindings cmtTbl
+ | Pstr_type(recFlag, typeDeclarations) ->
+ let recFlag = match recFlag with
+ | Asttypes.Nonrecursive -> Doc.nil
+ | Asttypes.Recursive -> Doc.text "rec "
+ in
+ printTypeDeclarations ~recFlag typeDeclarations cmtTbl
+ | Pstr_primitive valueDescription ->
+ printValueDescription valueDescription cmtTbl
+ | Pstr_eval (expr, attrs) ->
+ let exprDoc =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.structureExpr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ exprDoc;
+ ]
+ | Pstr_attribute attr -> Doc.concat [
+ Doc.text "@";
+ printAttribute attr cmtTbl
+ ]
+ | Pstr_extension (extension, attrs) -> Doc.concat [
+ printAttributes attrs cmtTbl;
+ Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl];
+ ]
+ | Pstr_include includeDeclaration ->
+ printIncludeDeclaration includeDeclaration cmtTbl
+ | Pstr_open openDescription ->
+ printOpenDescription openDescription cmtTbl
+ | Pstr_modtype modTypeDecl ->
+ printModuleTypeDeclaration modTypeDecl cmtTbl
+ | Pstr_module moduleBinding ->
+ printModuleBinding ~isRec:false moduleBinding cmtTbl 0
+ | Pstr_recmodule moduleBindings ->
+ printListi
+ ~getLoc:(fun mb -> mb.Parsetree.pmb_loc)
+ ~nodes:moduleBindings
+ ~print:(printModuleBinding ~isRec:true)
+ cmtTbl
+ | Pstr_exception extensionConstructor ->
+ printExceptionDef extensionConstructor cmtTbl
+ | Pstr_typext typeExtension ->
+ printTypeExtension typeExtension cmtTbl
+ | Pstr_class _ | Pstr_class_type _ -> Doc.nil
+
+and printTypeExtension (te : Parsetree.type_extension) cmtTbl =
+ let prefix = Doc.text "type " in
+ let name = printLidentPath te.ptyext_path cmtTbl in
+ let typeParams = printTypeParams te.ptyext_params cmtTbl in
+ let extensionConstructors =
+ let ecs = te.ptyext_constructors in
+ let forceBreak =
+ match (ecs, List.rev ecs) with
+ | (first::_, last::_) ->
+ first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum ||
+ first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum
+ | _ -> false
+ in
+ let privateFlag = match te.ptyext_private with
+ | Asttypes.Private -> Doc.concat [
+ Doc.text "private";
+ Doc.line;
+ ]
+ | Public -> Doc.nil
+ in
+ let rows =
+ printListi
+ ~getLoc:(fun n -> n.Parsetree.pext_loc)
+ ~print:printExtensionConstructor
+ ~nodes: ecs
+ ~forceBreak
+ cmtTbl
+ in
+ Doc.breakableGroup ~forceBreak (
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ privateFlag;
+ rows;
+ (* Doc.join ~sep:Doc.line ( *)
+ (* List.mapi printExtensionConstructor ecs *)
+ (* ) *)
+ ]
+ )
+ )
+ in
+ Doc.group (
+ Doc.concat [
+ printAttributes ~loc: te.ptyext_path.loc te.ptyext_attributes cmtTbl;
+ prefix;
+ name;
+ typeParams;
+ Doc.text " +=";
+ extensionConstructors;
+ ]
+ )
+
+and printModuleBinding ~isRec moduleBinding cmtTbl i =
+ let prefix = if i = 0 then
+ Doc.concat [
+ Doc.text "module ";
+ if isRec then Doc.text "rec " else Doc.nil;
+ ]
+ else
+ Doc.text "and "
+ in
+ let (modExprDoc, modConstraintDoc) =
+ match moduleBinding.pmb_expr with
+ | {pmod_desc = Pmod_constraint (modExpr, modType)} ->
+ (
+ printModExpr modExpr cmtTbl,
+ Doc.concat [
+ Doc.text ": ";
+ printModType modType cmtTbl
+ ]
+ )
+ | modExpr ->
+ (printModExpr modExpr cmtTbl, Doc.nil)
+ in
+ let modName =
+ let doc = Doc.text moduleBinding.pmb_name.Location.txt in
+ printComments doc cmtTbl moduleBinding.pmb_name.loc
+ in
+ let doc = Doc.concat [
+ printAttributes
+ ~loc:moduleBinding.pmb_name.loc moduleBinding.pmb_attributes cmtTbl;
+ prefix;
+ modName;
+ modConstraintDoc;
+ Doc.text " = ";
+ modExprDoc;
+ ] in
+ printComments doc cmtTbl moduleBinding.pmb_loc
+
+and printModuleTypeDeclaration (modTypeDecl : Parsetree.module_type_declaration) cmtTbl =
+ let modName =
+ let doc = Doc.text modTypeDecl.pmtd_name.txt in
+ printComments doc cmtTbl modTypeDecl.pmtd_name.loc
+ in
+ Doc.concat [
+ printAttributes modTypeDecl.pmtd_attributes cmtTbl;
+ Doc.text "module type ";
+ modName;
+ (match modTypeDecl.pmtd_type with
+ | None -> Doc.nil
+ | Some modType -> Doc.concat [
+ Doc.text " = ";
+ printModType modType cmtTbl;
+ ]);
+ ]
+
+and printModType modType cmtTbl =
+ let modTypeDoc = match modType.pmty_desc with
+ | Parsetree.Pmty_ident longident ->
+ Doc.concat [
+ printAttributes ~loc:longident.loc modType.pmty_attributes cmtTbl;
+ printLongidentLocation longident cmtTbl
+ ]
+ | Pmty_signature [] ->
+ let shouldBreak =
+ modType.pmty_loc.loc_start.pos_lnum < modType.pmty_loc.loc_end.pos_lnum
+ in
+ Doc.breakableGroup ~forceBreak:shouldBreak (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ printCommentsInside cmtTbl modType.pmty_loc;
+ ];
+ );
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+ | Pmty_signature signature ->
+ let signatureDoc = Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printSignature signature cmtTbl;
+ ]
+ );
+ Doc.line;
+ Doc.rbrace;
+ ]
+ ) in
+ Doc.concat [
+ printAttributes modType.pmty_attributes cmtTbl;
+ signatureDoc
+ ]
+ | Pmty_functor _ ->
+ let (parameters, returnType) = ParsetreeViewer.functorType modType in
+ let parametersDoc = match parameters with
+ | [] -> Doc.nil
+ | [attrs, {Location.txt = "_"; loc}, Some modType] ->
+ let cmtLoc =
+ {loc with loc_end = modType.Parsetree.pmty_loc.loc_end}
+ in
+ let attrs = printAttributes attrs cmtTbl in
+ let doc = Doc.concat [
+ attrs;
+ printModType modType cmtTbl
+ ] in
+ printComments doc cmtTbl cmtLoc
+ | params ->
+ Doc.group (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun (attrs, lbl, modType) ->
+ let cmtLoc = match modType with
+ | None -> lbl.Asttypes.loc
+ | Some modType ->
+ {lbl.Asttypes.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}
+ in
+ let attrs = printAttributes attrs cmtTbl in
+ let lblDoc = if lbl.Location.txt = "_" then Doc.nil
+ else
+ let doc = Doc.text lbl.txt in
+ printComments doc cmtTbl lbl.loc
+ in
+ let doc = Doc.concat [
+ attrs;
+ lblDoc;
+ (match modType with
+ | None -> Doc.nil
+ | Some modType -> Doc.concat [
+ if lbl.txt = "_" then Doc.nil else Doc.text ": ";
+ printModType modType cmtTbl;
+ ]);
+ ] in
+ printComments doc cmtTbl cmtLoc
+ ) params
+ );
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ in
+ let returnDoc =
+ let doc = printModType returnType cmtTbl in
+ if Parens.modTypeFunctorReturn returnType then addParens doc else doc
+ in
+ Doc.group (
+ Doc.concat [
+ parametersDoc;
+ Doc.group (
+ Doc.concat [
+ Doc.text " =>";
+ Doc.line;
+ returnDoc;
+ ]
+ )
+ ]
+ )
+ | Pmty_typeof modExpr -> Doc.concat [
+ Doc.text "module type of ";
+ printModExpr modExpr cmtTbl
+ ]
+ | Pmty_extension extension -> printExtension ~atModuleLvl:false extension cmtTbl
+ | Pmty_alias longident -> Doc.concat [
+ Doc.text "module ";
+ printLongidentLocation longident cmtTbl;
+ ]
+ | Pmty_with (modType, withConstraints) ->
+ let operand =
+ let doc = printModType modType cmtTbl in
+ if Parens.modTypeWithOperand modType then addParens doc else doc
+ in
+ Doc.group (
+ Doc.concat [
+ operand;
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printWithConstraints withConstraints cmtTbl;
+ ]
+ )
+ ]
+ )
+ in
+ let attrsAlreadyPrinted = match modType.pmty_desc with
+ | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true
+ | _ -> false
+ in
+ let doc =Doc.concat [
+ if attrsAlreadyPrinted then Doc.nil else printAttributes modType.pmty_attributes cmtTbl;
+ modTypeDoc;
+ ] in
+ printComments doc cmtTbl modType.pmty_loc
+
+and printWithConstraints withConstraints cmtTbl =
+ let rows = List.mapi (fun i withConstraint ->
+ Doc.group (
+ Doc.concat [
+ if i == 0 then Doc.text "with " else Doc.text "and ";
+ printWithConstraint withConstraint cmtTbl;
+ ]
+ )
+ ) withConstraints
+ in
+ Doc.join ~sep:Doc.line rows
+
+and printWithConstraint (withConstraint : Parsetree.with_constraint) cmtTbl =
+ match withConstraint with
+ (* with type X.t = ... *)
+ | Pwith_type (longident, typeDeclaration) ->
+ Doc.group (printTypeDeclaration
+ ~name:(printLidentPath longident cmtTbl)
+ ~equalSign:"="
+ ~recFlag:Doc.nil
+ 0
+ typeDeclaration
+ CommentTable.empty)
+ (* with module X.Y = Z *)
+ | Pwith_module ({txt = longident1}, {txt = longident2}) ->
+ Doc.concat [
+ Doc.text "module ";
+ printLongident longident1;
+ Doc.text " =";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printLongident longident2;
+ ]
+ )
+ ]
+ (* with type X.t := ..., same format as [Pwith_type] *)
+ | Pwith_typesubst (longident, typeDeclaration) ->
+ Doc.group(printTypeDeclaration
+ ~name:(printLidentPath longident cmtTbl)
+ ~equalSign:":="
+ ~recFlag:Doc.nil
+ 0
+ typeDeclaration
+ CommentTable.empty)
+ | Pwith_modsubst ({txt = longident1}, {txt = longident2}) ->
+ Doc.concat [
+ Doc.text "module ";
+ printLongident longident1;
+ Doc.text " :=";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printLongident longident2;
+ ]
+ )
+ ]
+
+and printSignature signature cmtTbl =
+ match signature with
+ | [] -> printCommentsInside cmtTbl Location.none
+ | signature ->
+ printList
+ ~getLoc:(fun s -> s.Parsetree.psig_loc)
+ ~nodes:signature
+ ~print:printSignatureItem
+ cmtTbl
+
+and printSignatureItem (si : Parsetree.signature_item) cmtTbl =
+ match si.psig_desc with
+ | Parsetree.Psig_value valueDescription ->
+ printValueDescription valueDescription cmtTbl
+ | Psig_type (recFlag, typeDeclarations) ->
+ let recFlag = match recFlag with
+ | Asttypes.Nonrecursive -> Doc.nil
+ | Asttypes.Recursive -> Doc.text "rec "
+ in
+ printTypeDeclarations ~recFlag typeDeclarations cmtTbl
+ | Psig_typext typeExtension ->
+ printTypeExtension typeExtension cmtTbl
+ | Psig_exception extensionConstructor ->
+ printExceptionDef extensionConstructor cmtTbl
+ | Psig_module moduleDeclaration ->
+ printModuleDeclaration moduleDeclaration cmtTbl
+ | Psig_recmodule moduleDeclarations ->
+ printRecModuleDeclarations moduleDeclarations cmtTbl
+ | Psig_modtype modTypeDecl ->
+ printModuleTypeDeclaration modTypeDecl cmtTbl
+ | Psig_open openDescription ->
+ printOpenDescription openDescription cmtTbl
+ | Psig_include includeDescription ->
+ printIncludeDescription includeDescription cmtTbl
+ | Psig_attribute attr -> Doc.concat [
+ Doc.text "@";
+ printAttribute attr cmtTbl
+ ]
+ | Psig_extension (extension, attrs) -> Doc.concat [
+ printAttributes attrs cmtTbl;
+ Doc.concat [printExtension ~atModuleLvl:true extension cmtTbl];
+ ]
+ | Psig_class _ | Psig_class_type _ -> Doc.nil
+
+and printRecModuleDeclarations moduleDeclarations cmtTbl =
+ printListi
+ ~getLoc:(fun n -> n.Parsetree.pmd_loc)
+ ~nodes:moduleDeclarations
+ ~print:printRecModuleDeclaration
+ cmtTbl
+
+and printRecModuleDeclaration md cmtTbl i =
+ let body = match md.pmd_type.pmty_desc with
+ | Parsetree.Pmty_alias longident ->
+ Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl]
+ | _ ->
+ let needsParens = match md.pmd_type.pmty_desc with
+ | Pmty_with _ -> true
+ | _ -> false
+ in
+ let modTypeDoc =
+ let doc = printModType md.pmd_type cmtTbl in
+ if needsParens then addParens doc else doc
+ in
+ Doc.concat [Doc.text ": "; modTypeDoc]
+ in
+ let prefix = if i < 1 then "module rec " else "and " in
+ Doc.concat [
+ printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl;
+ Doc.text prefix;
+ printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc;
+ body
+ ]
+
+and printModuleDeclaration (md: Parsetree.module_declaration) cmtTbl =
+ let body = match md.pmd_type.pmty_desc with
+ | Parsetree.Pmty_alias longident ->
+ Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl]
+ | _ -> Doc.concat [Doc.text ": "; printModType md.pmd_type cmtTbl]
+ in
+ Doc.concat [
+ printAttributes ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl;
+ Doc.text "module ";
+ printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc;
+ body
+ ]
+
+and printOpenDescription (openDescription : Parsetree.open_description) cmtTbl =
+ Doc.concat [
+ printAttributes openDescription.popen_attributes cmtTbl;
+ Doc.text "open";
+ (match openDescription.popen_override with
+ | Asttypes.Fresh -> Doc.space
+ | Asttypes.Override -> Doc.text "! ");
+ printLongidentLocation openDescription.popen_lid cmtTbl
+ ]
+
+and printIncludeDescription (includeDescription: Parsetree.include_description) cmtTbl =
+ Doc.concat [
+ printAttributes includeDescription.pincl_attributes cmtTbl;
+ Doc.text "include ";
+ printModType includeDescription.pincl_mod cmtTbl;
+ ]
+
+and printIncludeDeclaration (includeDeclaration : Parsetree.include_declaration) cmtTbl =
+ Doc.concat [
+ printAttributes includeDeclaration.pincl_attributes cmtTbl;
+ Doc.text "include ";
+ let includeDoc =
+ printModExpr includeDeclaration.pincl_mod cmtTbl
+ in
+ if Parens.includeModExpr includeDeclaration.pincl_mod then
+ addParens includeDoc
+ else includeDoc;
+ ]
+
+and printValueBindings ~recFlag (vbs: Parsetree.value_binding list) cmtTbl =
+ printListi
+ ~getLoc:(fun vb -> vb.Parsetree.pvb_loc)
+ ~nodes:vbs
+ ~print:(printValueBinding ~recFlag)
+ cmtTbl
+
+and printValueDescription valueDescription cmtTbl =
+ let isExternal =
+ match valueDescription.pval_prim with | [] -> false | _ -> true
+ in
+ let attrs =
+ printAttributes
+ ~loc:valueDescription.pval_name.loc
+ valueDescription.pval_attributes
+ cmtTbl
+ in
+ let header =
+ if isExternal then "external " else "let " in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ Doc.text header;
+ printComments
+ (printIdentLike valueDescription.pval_name.txt)
+ cmtTbl
+ valueDescription.pval_name.loc;
+ Doc.text ": ";
+ printTypExpr valueDescription.pval_type cmtTbl;
+ if isExternal then
+ Doc.group (
+ Doc.concat [
+ Doc.text " =";
+ Doc.indent(
+ Doc.concat [
+ Doc.line;
+ Doc.join ~sep:Doc.line (
+ List.map(fun s -> Doc.concat [
+ Doc.text "\"";
+ Doc.text s;
+ Doc.text "\"";
+ ])
+ valueDescription.pval_prim
+ );
+ ]
+ )
+ ]
+ )
+ else Doc.nil
+ ]
+ )
+
+and printTypeDeclarations ~recFlag typeDeclarations cmtTbl =
+ printListi
+ ~getLoc:(fun n -> n.Parsetree.ptype_loc)
+ ~nodes:typeDeclarations
+ ~print:(printTypeDeclaration2 ~recFlag)
+ cmtTbl
+
+(*
+ * type_declaration = {
+ * ptype_name: string loc;
+ * ptype_params: (core_type * variance) list;
+ * (* ('a1,...'an) t; None represents _*)
+ * ptype_cstrs: (core_type * core_type * Location.t) list;
+ * (* ... constraint T1=T1' ... constraint Tn=Tn' *)
+ * ptype_kind: type_kind;
+ * ptype_private: private_flag; (* = private ... *)
+ * ptype_manifest: core_type option; (* = T *)
+ * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *)
+ * ptype_loc: Location.t;
+ * }
+ *
+ *
+ * type t (abstract, no manifest)
+ * type t = T0 (abstract, manifest=T0)
+ * type t = C of T | ... (variant, no manifest)
+ * type t = T0 = C of T | ... (variant, manifest=T0)
+ * type t = {l: T; ...} (record, no manifest)
+ * type t = T0 = {l : T; ...} (record, manifest=T0)
+ * type t = .. (open, no manifest)
+ *
+ *
+ * and type_kind =
+ * | Ptype_abstract
+ * | Ptype_variant of constructor_declaration list
+ * (* Invariant: non-empty list *)
+ * | Ptype_record of label_declaration list
+ * (* Invariant: non-empty list *)
+ * | Ptype_open
+ *)
+and printTypeDeclaration ~name ~equalSign ~recFlag i (td: Parsetree.type_declaration) cmtTbl =
+ let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in
+ let prefix = if i > 0 then
+ Doc.text "and "
+ else
+ Doc.concat [Doc.text "type "; recFlag]
+ in
+ let typeName = name in
+ let typeParams = printTypeParams td.ptype_params cmtTbl in
+ let manifestAndKind = match td.ptype_kind with
+ | Ptype_abstract ->
+ begin match td.ptype_manifest with
+ | None -> Doc.nil
+ | Some(typ) ->
+ Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printPrivateFlag td.ptype_private;
+ printTypExpr typ cmtTbl;
+ ]
+ end
+ | Ptype_open -> Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printPrivateFlag td.ptype_private;
+ Doc.text "..";
+ ]
+ | Ptype_record(lds) ->
+ let manifest = match td.ptype_manifest with
+ | None -> Doc.nil
+ | Some(typ) -> Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printTypExpr typ cmtTbl;
+ ]
+ in
+ Doc.concat [
+ manifest;
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printPrivateFlag td.ptype_private;
+ printRecordDeclaration lds cmtTbl;
+ ]
+ | Ptype_variant(cds) ->
+ let manifest = match td.ptype_manifest with
+ | None -> Doc.nil
+ | Some(typ) -> Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printTypExpr typ cmtTbl;
+ ]
+ in
+ Doc.concat [
+ manifest;
+ Doc.concat [Doc.space; Doc.text equalSign];
+ printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl;
+ ]
+ in
+ let constraints = printTypeDefinitionConstraints td.ptype_cstrs in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ prefix;
+ typeName;
+ typeParams;
+ manifestAndKind;
+ constraints;
+ ]
+ )
+
+and printTypeDeclaration2 ~recFlag (td: Parsetree.type_declaration) cmtTbl i =
+ let name =
+ let doc = printIdentLike td.Parsetree.ptype_name.txt in
+ printComments doc cmtTbl td.ptype_name.loc
+ in
+ let equalSign = "=" in
+ let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes cmtTbl in
+ let prefix = if i > 0 then
+ Doc.text "and "
+ else
+ Doc.concat [
+ Doc.text "type ";
+ recFlag
+ ]
+ in
+ let typeName = name in
+ let typeParams = printTypeParams td.ptype_params cmtTbl in
+ let manifestAndKind = match td.ptype_kind with
+ | Ptype_abstract ->
+ begin match td.ptype_manifest with
+ | None -> Doc.nil
+ | Some(typ) ->
+ Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printPrivateFlag td.ptype_private;
+ printTypExpr typ cmtTbl;
+ ]
+ end
+ | Ptype_open -> Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printPrivateFlag td.ptype_private;
+ Doc.text "..";
+ ]
+ | Ptype_record(lds) ->
+ let manifest = match td.ptype_manifest with
+ | None -> Doc.nil
+ | Some(typ) -> Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printTypExpr typ cmtTbl;
+ ]
+ in
+ Doc.concat [
+ manifest;
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printPrivateFlag td.ptype_private;
+ printRecordDeclaration lds cmtTbl;
+ ]
+ | Ptype_variant(cds) ->
+ let manifest = match td.ptype_manifest with
+ | None -> Doc.nil
+ | Some(typ) -> Doc.concat [
+ Doc.concat [Doc.space; Doc.text equalSign; Doc.space];
+ printTypExpr typ cmtTbl;
+ ]
+ in
+ Doc.concat [
+ manifest;
+ Doc.concat [Doc.space; Doc.text equalSign];
+ printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl;
+ ]
+ in
+ let constraints = printTypeDefinitionConstraints td.ptype_cstrs in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ prefix;
+ typeName;
+ typeParams;
+ manifestAndKind;
+ constraints;
+ ]
+ )
+
+and printTypeDefinitionConstraints cstrs =
+ match cstrs with
+ | [] -> Doc.nil
+ | cstrs -> Doc.indent (
+ Doc.group (
+ Doc.concat [
+ Doc.line;
+ Doc.group(
+ Doc.join ~sep:Doc.line (
+ List.map printTypeDefinitionConstraint cstrs
+ )
+ )
+ ]
+ )
+ )
+
+and printTypeDefinitionConstraint ((typ1, typ2, _loc ): Parsetree.core_type * Parsetree.core_type * Location.t) =
+ Doc.concat [
+ Doc.text "constraint ";
+ printTypExpr typ1 CommentTable.empty;
+ Doc.text " = ";
+ printTypExpr typ2 CommentTable.empty;
+ ]
+
+and printPrivateFlag (flag : Asttypes.private_flag) = match flag with
+ | Private -> Doc.text "private "
+ | Public -> Doc.nil
+
+and printTypeParams typeParams cmtTbl =
+ match typeParams with
+ | [] -> Doc.nil
+ | typeParams ->
+ Doc.group (
+ Doc.concat [
+ Doc.lessThan;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun typeParam ->
+ let doc = printTypeParam typeParam cmtTbl in
+ printComments doc cmtTbl (fst typeParam).Parsetree.ptyp_loc
+ ) typeParams
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.greaterThan;
+ ]
+ )
+
+and printTypeParam (param : (Parsetree.core_type * Asttypes.variance)) cmtTbl =
+ let (typ, variance) = param in
+ let printedVariance = match variance with
+ | Covariant -> Doc.text "+"
+ | Contravariant -> Doc.text "-"
+ | Invariant -> Doc.nil
+ in
+ Doc.concat [
+ printedVariance;
+ printTypExpr typ cmtTbl
+ ]
+
+and printRecordDeclaration (lds: Parsetree.label_declaration list) cmtTbl =
+ let forceBreak = match (lds, List.rev lds) with
+ | (first::_, last::_) ->
+ first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum
+ | _ -> false
+ in
+ Doc.breakableGroup ~forceBreak (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line])
+ (List.map (fun ld ->
+ let doc = printLabelDeclaration ld cmtTbl in
+ printComments doc cmtTbl ld.Parsetree.pld_loc
+ ) lds)
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+
+and printConstructorDeclarations
+ ~privateFlag (cds: Parsetree.constructor_declaration list) cmtTbl
+=
+ let forceBreak = match (cds, List.rev cds) with
+ | (first::_, last::_) ->
+ first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum
+ | _ -> false
+ in
+ let privateFlag = match privateFlag with
+ | Asttypes.Private -> Doc.concat [
+ Doc.text "private";
+ Doc.line;
+ ]
+ | Public -> Doc.nil
+ in
+ let rows =
+ printListi
+ ~getLoc:(fun cd -> cd.Parsetree.pcd_loc)
+ ~nodes:cds
+ ~print:(fun cd cmtTbl i ->
+ let doc = printConstructorDeclaration2 i cd cmtTbl in
+ printComments doc cmtTbl cd.Parsetree.pcd_loc
+ )
+ ~forceBreak
+ cmtTbl
+ in
+ Doc.breakableGroup ~forceBreak (
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ privateFlag;
+ rows;
+ ]
+ )
+ )
+
+and printConstructorDeclaration2 i (cd : Parsetree.constructor_declaration) cmtTbl =
+ let attrs = printAttributes cd.pcd_attributes cmtTbl in
+ let bar = if i > 0 || cd.pcd_attributes <> [] then Doc.text "| "
+ else Doc.ifBreaks (Doc.text "| ") Doc.nil
+ in
+ let constrName =
+ let doc = Doc.text cd.pcd_name.txt in
+ printComments doc cmtTbl cd.pcd_name.loc
+ in
+ let constrArgs = printConstructorArguments ~indent:true cd.pcd_args cmtTbl in
+ let gadt = match cd.pcd_res with
+ | None -> Doc.nil
+ | Some(typ) -> Doc.indent (
+ Doc.concat [
+ Doc.text ": ";
+ printTypExpr typ cmtTbl;
+ ]
+ )
+ in
+ Doc.concat [
+ bar;
+ Doc.group (
+ Doc.concat [
+ attrs; (* TODO: fix parsing of attributes, so when can print them above the bar? *)
+ constrName;
+ constrArgs;
+ gadt;
+ ]
+ )
+ ]
+
+and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) cmtTbl =
+ match cdArgs with
+ | Pcstr_tuple [] -> Doc.nil
+ | Pcstr_tuple types ->
+ let args = Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun typexpr ->
+ printTypExpr typexpr cmtTbl
+ ) types
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ] in
+ Doc.group (
+ if indent then Doc.indent args else args
+ )
+ | Pcstr_record lds ->
+ let args = Doc.concat [
+ Doc.lparen;
+ (* manually inline the printRecordDeclaration, gives better layout *)
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line])
+ (List.map (fun ld ->
+ let doc = printLabelDeclaration ld cmtTbl in
+ printComments doc cmtTbl ld.Parsetree.pld_loc
+ ) lds)
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ Doc.rparen;
+ ] in
+ if indent then Doc.indent args else args
+
+and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl =
+ let attrs = printAttributes ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl in
+ let mutableFlag = match ld.pld_mutable with
+ | Mutable -> Doc.text "mutable "
+ | Immutable -> Doc.nil
+ in
+ let name =
+ let doc = printIdentLike ld.pld_name.txt in
+ printComments doc cmtTbl ld.pld_name.loc
+ in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ mutableFlag;
+ name;
+ Doc.text ": ";
+ printTypExpr ld.pld_type cmtTbl;
+ ]
+ )
+
+and printTypExpr (typExpr : Parsetree.core_type) cmtTbl =
+ let renderedType = match typExpr.ptyp_desc with
+ | Ptyp_any -> Doc.text "_"
+ | Ptyp_var var -> Doc.concat [
+ Doc.text "'";
+ printIdentLike ~allowUident:true var;
+ ]
+ | Ptyp_extension(extension) ->
+ printExtension ~atModuleLvl:false extension cmtTbl
+ | Ptyp_alias(typ, alias) ->
+ let typ =
+ (* Technically type t = (string, float) => unit as 'x, doesn't require
+ * parens around the arrow expression. This is very confusing though.
+ * Is the "as" part of "unit" or "(string, float) => unit". By printing
+ * parens we guide the user towards its meaning.*)
+ let needsParens = match typ.ptyp_desc with
+ | Ptyp_arrow _ -> true
+ | _ -> false
+ in
+ let doc = printTypExpr typ cmtTbl in
+ if needsParens then
+ Doc.concat [Doc.lparen; doc; Doc.rparen]
+ else
+ doc
+ in
+ Doc.concat [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]]
+
+ (* object printings *)
+ | Ptyp_object (fields, openFlag) ->
+ printObject ~inline:false fields openFlag cmtTbl
+ | Ptyp_constr(longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) ->
+ (* for foo<{"a": b}>, when the object is long and needs a line break, we
+ want the <{ and }> to stay hugged together *)
+ let constrName = printLidentPath longidentLoc cmtTbl in
+ Doc.concat([
+ constrName;
+ Doc.lessThan;
+ printObject ~inline:true fields openFlag cmtTbl;
+ Doc.greaterThan;
+ ])
+
+ | Ptyp_constr(longidentLoc, [{ ptyp_desc = Parsetree.Ptyp_tuple tuple }]) ->
+ let constrName = printLidentPath longidentLoc cmtTbl in
+ Doc.group(
+ Doc.concat([
+ constrName;
+ Doc.lessThan;
+ printTupleType ~inline:true tuple cmtTbl;
+ Doc.greaterThan;
+ ])
+ )
+ | Ptyp_constr(longidentLoc, constrArgs) ->
+ let constrName = printLidentPath longidentLoc cmtTbl in
+ begin match constrArgs with
+ | [] -> constrName
+ | _args -> Doc.group(
+ Doc.concat([
+ constrName;
+ Doc.lessThan;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map
+ (fun typexpr -> printTypExpr typexpr cmtTbl)
+ constrArgs
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.greaterThan;
+ ])
+ )
+ end
+ | Ptyp_arrow _ ->
+ let (attrsBefore, args, returnType) = ParsetreeViewer.arrowType typExpr in
+ let returnTypeNeedsParens = match returnType.ptyp_desc with
+ | Ptyp_alias _ -> true
+ | _ -> false
+ in
+ let returnDoc =
+ let doc = printTypExpr returnType cmtTbl in
+ if returnTypeNeedsParens then
+ Doc.concat [Doc.lparen; doc; Doc.rparen]
+ else doc
+ in
+ let (isUncurried, attrs) =
+ ParsetreeViewer.processUncurriedAttribute attrsBefore
+ in
+ begin match args with
+ | [] -> Doc.nil
+ | [([], Nolabel, n)] when not isUncurried ->
+ let hasAttrsBefore = not (attrs = []) in
+ let attrs = if hasAttrsBefore then printAttributes ~inline:true attrsBefore cmtTbl else Doc.nil
+ in
+ let typDoc =
+ let doc = printTypExpr n cmtTbl in
+ match n.ptyp_desc with
+ | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc
+ | _ -> doc
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.group attrs;
+ Doc.group (
+ if hasAttrsBefore then
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ typDoc;
+ Doc.text " => ";
+ returnDoc;
+ ]
+ );
+ Doc.softLine;
+ Doc.rparen
+ ]
+ else
+ Doc.concat [
+ typDoc;
+ Doc.text " => ";
+ returnDoc;
+ ]
+ )
+ ]
+ )
+ | args ->
+ let attrs = printAttributes ~inline:true attrs cmtTbl in
+ let renderedArgs = Doc.concat [
+ attrs;
+ Doc.text "(";
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun tp ->
+ printTypeParameter tp cmtTbl
+ ) args
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.text ")";
+ ] in
+ Doc.group (
+ Doc.concat [
+ renderedArgs;
+ Doc.text " => ";
+ returnDoc;
+ ]
+ )
+ end
+ | Ptyp_tuple types -> printTupleType ~inline:false types cmtTbl
+ | Ptyp_poly([], typ) ->
+ printTypExpr typ cmtTbl
+ | Ptyp_poly(stringLocs, typ) ->
+ Doc.concat [
+ Doc.join ~sep:Doc.space (List.map (fun {Location.txt; loc} ->
+ let doc = Doc.concat [Doc.text "'"; Doc.text txt] in
+ printComments doc cmtTbl loc
+ ) stringLocs);
+ Doc.dot;
+ Doc.space;
+ printTypExpr typ cmtTbl
+ ]
+ | Ptyp_package packageType ->
+ printPackageType ~printModuleKeywordAndParens:true packageType cmtTbl
+ | Ptyp_class _ ->
+ Doc.text "classes are not supported in types"
+ | Ptyp_variant (rowFields, closedFlag, labelsOpt) ->
+ let forceBreak = typExpr.ptyp_loc.Location.loc_start.pos_lnum < typExpr.ptyp_loc.loc_end.pos_lnum in
+ let printRowField = function
+ | Parsetree.Rtag ({txt}, attrs, true, []) ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ Doc.concat [Doc.text "#"; printPolyVarIdent txt]
+ ]
+ )
+ | Rtag ({txt}, attrs, truth, types) ->
+ let doType t = match t.Parsetree.ptyp_desc with
+ | Ptyp_tuple _ -> printTypExpr t cmtTbl
+ | _ -> Doc.concat [ Doc.lparen; printTypExpr t cmtTbl; Doc.rparen ]
+ in
+ let printedTypes = List.map doType types in
+ let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes in
+ let cases = if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases in
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ Doc.concat [Doc.text "#"; printPolyVarIdent txt];
+ cases
+ ]
+ )
+ | Rinherit coreType ->
+ printTypExpr coreType cmtTbl
+ in
+ let docs = List.map printRowField rowFields in
+ let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in
+ let cases =
+ if docs = [] then cases
+ else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases]
+ in
+ let openingSymbol =
+ if closedFlag = Open
+ then Doc.concat [Doc.greaterThan; Doc.line]
+ else if labelsOpt = None
+ then Doc.softLine
+ else Doc.concat [Doc.lessThan; Doc.line] in
+ let labels = match labelsOpt with
+ | None
+ | Some([]) ->
+ Doc.nil
+ | Some(labels) ->
+ Doc.concat (
+ List.map (fun label ->
+ Doc.concat [Doc.line; Doc.text "#" ; printPolyVarIdent label]
+ ) labels
+ )
+ in
+ let closingSymbol = match labelsOpt with
+ | None | Some [] -> Doc.nil
+ | _ -> Doc.text " >"
+ in
+ Doc.breakableGroup ~forceBreak (
+ Doc.concat [
+ Doc.lbracket;
+ Doc.indent (
+ Doc.concat [
+ openingSymbol;
+ cases;
+ closingSymbol;
+ labels;
+ ]
+ );
+ Doc.softLine;
+ Doc.rbracket
+ ]
+ )
+ in
+ let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with
+ | Ptyp_arrow _ (* es6 arrow types print their own attributes *) -> true
+ | _ -> false
+ in
+ let doc = begin match typExpr.ptyp_attributes with
+ | _::_ as attrs when not shouldPrintItsOwnAttributes ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ renderedType;
+ ]
+ )
+ | _ -> renderedType
+ end
+ in
+ printComments doc cmtTbl typExpr.ptyp_loc
+
+and printObject ~inline fields openFlag cmtTbl =
+ let doc = match fields with
+ | [] -> Doc.concat [
+ Doc.lbrace;
+ (match openFlag with
+ | Asttypes.Closed -> Doc.dot
+ | Open -> Doc.dotdot);
+ Doc.rbrace
+ ]
+ | fields ->
+ Doc.concat [
+ Doc.lbrace;
+ (match openFlag with
+ | Asttypes.Closed -> Doc.nil
+ | Open ->
+ begin match fields with
+ (* handle `type t = {.. ...objType, "x": int}`
+ * .. and ... should have a space in between *)
+ | (Oinherit _)::_ -> Doc.text ".. "
+ | _ -> Doc.dotdot
+ end
+ );
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun field -> printObjectField field cmtTbl) fields
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ in
+ if inline then doc else Doc.group doc
+
+and printTupleType ~inline (types: Parsetree.core_type list) cmtTbl =
+ let tuple = Doc.concat([
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat([
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun typexpr -> printTypExpr typexpr cmtTbl) types
+ )
+ ])
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ])
+ in
+ if inline == false then Doc.group(tuple) else tuple
+
+and printObjectField (field : Parsetree.object_field) cmtTbl =
+ match field with
+ | Otag (labelLoc, attrs, typ) ->
+ let lbl =
+ let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in
+ printComments doc cmtTbl labelLoc.loc
+ in
+ let doc = Doc.concat [
+ printAttributes ~loc:labelLoc.loc attrs cmtTbl;
+ lbl;
+ Doc.text ": ";
+ printTypExpr typ cmtTbl;
+ ] in
+ let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in
+ printComments doc cmtTbl cmtLoc
+ | Oinherit typexpr ->
+ Doc.concat [
+ Doc.dotdotdot;
+ printTypExpr typexpr cmtTbl
+ ]
+
+(* es6 arrow type arg
+ * type t = (~foo: string, ~bar: float=?, unit) => unit
+ * i.e. ~foo: string, ~bar: float *)
+and printTypeParameter (attrs, lbl, typ) cmtTbl =
+ let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in
+ let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in
+ let attrs = printAttributes attrs cmtTbl in
+ let label = match lbl with
+ | Asttypes.Nolabel -> Doc.nil
+ | Labelled lbl -> Doc.concat [
+ Doc.text "~";
+ printIdentLike lbl;
+ Doc.text ": ";
+ ]
+ | Optional lbl -> Doc.concat [
+ Doc.text "~";
+ printIdentLike lbl;
+ Doc.text ": ";
+ ]
+ in
+ let optionalIndicator = match lbl with
+ | Asttypes.Nolabel
+ | Labelled _ -> Doc.nil
+ | Optional _lbl -> Doc.text "=?"
+ in
+ let (loc, typ) = match typ.ptyp_attributes with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs ->
+ ({loc with loc_end = typ.ptyp_loc.loc_end}, {typ with ptyp_attributes = attrs})
+ | _ -> (typ.ptyp_loc, typ)
+ in
+ let doc = Doc.group (
+ Doc.concat [
+ uncurried;
+ attrs;
+ label;
+ printTypExpr typ cmtTbl;
+ optionalIndicator;
+ ]
+ ) in
+ printComments doc cmtTbl loc
+
+and printValueBinding ~recFlag vb cmtTbl i =
+ let attrs = printAttributes ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes cmtTbl in
+ let header =
+ if i == 0 then
+ Doc.concat [
+ Doc.text "let ";
+ recFlag
+ ] else
+ Doc.text "and "
+ in
+ match vb with
+ | {pvb_pat =
+ {ppat_desc = Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp))};
+ pvb_expr =
+ {pexp_desc = Pexp_newtype _} as expr
+ } ->
+ let (_attrs, parameters, returnExpr) = ParsetreeViewer.funExpr expr in
+ let abstractType = match parameters with
+ | [NewTypes {locs = vars}] ->
+ Doc.concat [
+ Doc.text "type ";
+ Doc.join ~sep:Doc.space (List.map (fun var -> Doc.text var.Asttypes.txt) vars);
+ Doc.dot;
+ ]
+ | _ -> Doc.nil
+ in
+ begin match returnExpr.pexp_desc with
+ | Pexp_constraint (expr, typ) ->
+ Doc.group (
+ Doc.concat [
+ attrs;
+ header;
+ printPattern pattern cmtTbl;
+ Doc.text ":";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ abstractType;
+ Doc.space;
+ printTypExpr typ cmtTbl;
+ Doc.text " =";
+ Doc.concat [
+ Doc.line;
+ printExpressionWithComments expr cmtTbl;
+ ]
+ ]
+ )
+ ]
+ )
+ | _ ->
+ (* Example:
+ * let cancel_and_collect_callbacks:
+ * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>)
+ *)
+ Doc.group (
+ Doc.concat [
+ attrs;
+ header;
+ printPattern pattern cmtTbl;
+ Doc.text ":";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ abstractType;
+ Doc.space;
+ printTypExpr patTyp cmtTbl;
+ Doc.text " =";
+ Doc.concat [
+ Doc.line;
+ printExpressionWithComments expr cmtTbl;
+ ]
+ ]
+ )
+ ]
+ )
+ end
+ | _ ->
+ let (optBraces, expr) = ParsetreeViewer.processBracesAttr vb.pvb_expr in
+ let printedExpr =
+ let doc = printExpressionWithComments vb.pvb_expr cmtTbl in
+ match Parens.expr vb.pvb_expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ let patternDoc = printPattern vb.pvb_pat cmtTbl in
+ (*
+ * we want to optimize the layout of one pipe:
+ * let tbl = data->Js.Array2.reduce((map, curr) => {
+ * ...
+ * })
+ * important is that we don't do this for multiple pipes:
+ * let decoratorTags =
+ * items
+ * ->Js.Array2.filter(items => {items.category === Decorators})
+ * ->Belt.Array.map(...)
+ * Multiple pipes chained together lend themselves more towards the last layout.
+ *)
+ if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then
+ Doc.customLayout [
+ Doc.group (
+ Doc.concat [
+ attrs;
+ header;
+ patternDoc;
+ Doc.text " =";
+ Doc.space;
+ printedExpr;
+ ]
+ );
+ Doc.group (
+ Doc.concat [
+ attrs;
+ header;
+ patternDoc;
+ Doc.text " =";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printedExpr;
+ ]
+ )
+ ]
+ );
+ ]
+ else
+ let shouldIndent =
+ match optBraces with
+ | Some _ -> false
+ | _ ->
+ ParsetreeViewer.isBinaryExpression expr ||
+ (match vb.pvb_expr with
+ | {
+ pexp_attributes = [({Location.txt="ns.ternary"}, _)];
+ pexp_desc = Pexp_ifthenelse (ifExpr, _, _)
+ } ->
+ ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes
+ | { pexp_desc = Pexp_newtype _} -> false
+ | e ->
+ ParsetreeViewer.hasAttributes e.pexp_attributes ||
+ ParsetreeViewer.isArrayAccess e
+ )
+ in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ header;
+ patternDoc;
+ Doc.text " =";
+ if shouldIndent then
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printedExpr;
+ ]
+ )
+ else
+ Doc.concat [
+ Doc.space;
+ printedExpr;
+ ]
+ ]
+ )
+
+and printPackageType ~printModuleKeywordAndParens (packageType: Parsetree.package_type) cmtTbl =
+ let doc = match packageType with
+ | (longidentLoc, []) -> Doc.group(
+ Doc.concat [
+ printLongidentLocation longidentLoc cmtTbl;
+ ]
+ )
+ | (longidentLoc, packageConstraints) -> Doc.group(
+ Doc.concat [
+ printLongidentLocation longidentLoc cmtTbl;
+ printPackageConstraints packageConstraints cmtTbl;
+ Doc.softLine;
+ ]
+ )
+ in
+ if printModuleKeywordAndParens then
+ Doc.concat[
+ Doc.text "module(";
+ doc;
+ Doc.rparen
+ ]
+ else
+ doc
+
+and printPackageConstraints packageConstraints cmtTbl =
+ Doc.concat [
+ Doc.text " with";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ Doc.join ~sep:Doc.line (
+ List.mapi (fun i pc ->
+ let (longident, typexpr) = pc in
+ let cmtLoc = {longident.Asttypes.loc with
+ loc_end = typexpr.Parsetree.ptyp_loc.loc_end
+ } in
+ let doc = printPackageConstraint i cmtTbl pc in
+ printComments doc cmtTbl cmtLoc
+ ) packageConstraints
+ )
+ ]
+ )
+ ]
+
+and printPackageConstraint i cmtTbl (longidentLoc, typ) =
+ let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in
+ Doc.concat [
+ prefix;
+ printLongidentLocation longidentLoc cmtTbl;
+ Doc.text " = ";
+ printTypExpr typ cmtTbl;
+ ]
+
+and printExtension ~atModuleLvl (stringLoc, payload) cmtTbl =
+ let txt = convertBsExtension stringLoc.Location.txt in
+ let extName =
+ let doc = Doc.concat [
+ Doc.text "%";
+ if atModuleLvl then Doc.text "%" else Doc.nil;
+ Doc.text txt
+ ] in
+ printComments doc cmtTbl stringLoc.Location.loc
+ in
+ Doc.group (
+ Doc.concat [
+ extName;
+ printPayload payload cmtTbl;
+ ]
+ )
+
+and printPattern (p : Parsetree.pattern) cmtTbl =
+ let patternWithoutAttributes = match p.ppat_desc with
+ | Ppat_any -> Doc.text "_"
+ | Ppat_var var -> printIdentLike var.txt
+ | Ppat_constant c ->
+ let templateLiteral = ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes in
+ printConstant ~templateLiteral c
+ | Ppat_tuple patterns ->
+ Doc.group(
+ Doc.concat([
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat([
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun pat ->
+ printPattern pat cmtTbl) patterns)
+ ])
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen
+ ])
+ )
+ | Ppat_array [] ->
+ Doc.concat [
+ Doc.lbracket;
+ printCommentsInside cmtTbl p.ppat_loc;
+ Doc.rbracket;
+ ]
+ | Ppat_array patterns ->
+ Doc.group(
+ Doc.concat([
+ Doc.text "[";
+ Doc.indent (
+ Doc.concat([
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun pat ->
+ printPattern pat cmtTbl) patterns)
+ ])
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.text "]";
+ ])
+ )
+ | Ppat_construct({txt = Longident.Lident "()"}, _) ->
+ Doc.concat [
+ Doc.lparen;
+ printCommentsInside cmtTbl p.ppat_loc;
+ Doc.rparen;
+ ]
+ | Ppat_construct({txt = Longident.Lident "[]"}, _) ->
+ Doc.concat [
+ Doc.text "list{";
+ printCommentsInside cmtTbl p.ppat_loc;
+ Doc.rbrace;
+ ]
+ | Ppat_construct({txt = Longident.Lident "::"}, _) ->
+ let (patterns, tail) = ParsetreeViewer.collectPatternsFromListConstruct [] p in
+ let shouldHug = match (patterns, tail) with
+ | ([pat],
+ {ppat_desc = Ppat_construct({txt = Longident.Lident "[]"}, _)}) when ParsetreeViewer.isHuggablePattern pat -> true
+ | _ -> false
+ in
+ let children = Doc.concat([
+ if shouldHug then Doc.nil else Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun pat ->
+ printPattern pat cmtTbl) patterns);
+ begin match tail.Parsetree.ppat_desc with
+ | Ppat_construct({txt = Longident.Lident "[]"}, _) -> Doc.nil
+ | _ ->
+ let doc = Doc.concat [Doc.text "..."; printPattern tail cmtTbl] in
+ let tail = printComments doc cmtTbl tail.ppat_loc in
+ Doc.concat([Doc.text ","; Doc.line; tail])
+ end;
+ ]) in
+ Doc.group(
+ Doc.concat([
+ Doc.text "list{";
+ if shouldHug then children else Doc.concat [
+ Doc.indent children;
+ Doc.ifBreaks (Doc.text ",") Doc.nil;
+ Doc.softLine;
+ ];
+ Doc.rbrace;
+ ])
+ )
+ | Ppat_construct(constrName, constructorArgs) ->
+ let constrName = printLongidentLocation constrName cmtTbl in
+ let argsDoc = match constructorArgs with
+ | None -> Doc.nil
+ | Some({ppat_loc; ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) ->
+ Doc.concat [
+ Doc.lparen;
+ printCommentsInside cmtTbl ppat_loc;
+ Doc.rparen;
+ ]
+ | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.softLine;
+ printCommentsInside cmtTbl loc;
+ Doc.rparen;
+ ]
+ (* Some((1, 2) *)
+ | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) ->
+ Doc.concat [
+ Doc.lparen;
+ printPattern arg cmtTbl;
+ Doc.rparen;
+ ]
+ | Some({ppat_desc = Ppat_tuple patterns}) ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun pat -> printPattern pat cmtTbl) patterns
+ );
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ | Some(arg) ->
+ let argDoc = printPattern arg cmtTbl in
+ let shouldHug = ParsetreeViewer.isHuggablePattern arg in
+ Doc.concat [
+ Doc.lparen;
+ if shouldHug then argDoc
+ else Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ argDoc;
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ ];
+ Doc.rparen;
+
+ ]
+ in
+ Doc.group(Doc.concat [constrName; argsDoc])
+ | Ppat_variant (label, None) ->
+ Doc.concat [Doc.text "#"; printPolyVarIdent label]
+ | Ppat_variant (label, variantArgs) ->
+ let variantName =
+ Doc.concat [Doc.text "#"; printPolyVarIdent label] in
+ let argsDoc = match variantArgs with
+ | None -> Doc.nil
+ | Some({ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) ->
+ Doc.text "()"
+ | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.softLine;
+ printCommentsInside cmtTbl loc;
+ Doc.rparen;
+ ]
+ (* Some((1, 2) *)
+ | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) ->
+ Doc.concat [
+ Doc.lparen;
+ printPattern arg cmtTbl;
+ Doc.rparen;
+ ]
+ | Some({ppat_desc = Ppat_tuple patterns}) ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun pat -> printPattern pat cmtTbl) patterns
+ );
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ | Some(arg) ->
+ let argDoc = printPattern arg cmtTbl in
+ let shouldHug = ParsetreeViewer.isHuggablePattern arg in
+ Doc.concat [
+ Doc.lparen;
+ if shouldHug then argDoc
+ else Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ argDoc;
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ ];
+ Doc.rparen;
+
+ ]
+ in
+ Doc.group(Doc.concat [variantName; argsDoc])
+ | Ppat_type ident ->
+ Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl]
+ | Ppat_record(rows, openFlag) ->
+ Doc.group(
+ Doc.concat([
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun row -> printPatternRecordRow row cmtTbl) rows);
+ begin match openFlag with
+ | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"]
+ | Closed -> Doc.nil
+ end;
+ ]
+ );
+ Doc.ifBreaks (Doc.text ",") Doc.nil;
+ Doc.softLine;
+ Doc.rbrace;
+ ])
+ )
+
+ | Ppat_exception p ->
+ let needsParens = match p.ppat_desc with
+ | Ppat_or (_, _) | Ppat_alias (_, _) -> true
+ | _ -> false
+ in
+ let pat =
+ let p = printPattern p cmtTbl in
+ if needsParens then
+ Doc.concat [Doc.text "("; p; Doc.text ")"]
+ else
+ p
+ in
+ Doc.group (
+ Doc.concat [Doc.text "exception"; Doc.line; pat]
+ )
+ | Ppat_or _ ->
+ (* Blue | Red | Green -> [Blue; Red; Green] *)
+ let orChain = ParsetreeViewer.collectOrPatternChain p in
+ let docs = List.mapi (fun i pat ->
+ let patternDoc = printPattern pat cmtTbl in
+ Doc.concat [
+ if i == 0 then Doc.nil else Doc.concat [Doc.line; Doc.text "| "];
+ match pat.ppat_desc with
+ (* (Blue | Red) | (Green | Black) | White *)
+ | Ppat_or _ -> addParens patternDoc
+ | _ -> patternDoc
+ ]
+ ) orChain in
+ let isSpreadOverMultipleLines = match (orChain, List.rev orChain) with
+ | first::_, last::_ ->
+ first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum
+ | _ -> false
+ in
+ Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs)
+ | Ppat_extension ext ->
+ printExtension ~atModuleLvl:false ext cmtTbl
+ | Ppat_lazy p ->
+ let needsParens = match p.ppat_desc with
+ | Ppat_or (_, _) | Ppat_alias (_, _) -> true
+ | _ -> false
+ in
+ let pat =
+ let p = printPattern p cmtTbl in
+ if needsParens then
+ Doc.concat [Doc.text "("; p; Doc.text ")"]
+ else
+ p
+ in
+ Doc.concat [Doc.text "lazy "; pat]
+ | Ppat_alias (p, aliasLoc) ->
+ let needsParens = match p.ppat_desc with
+ | Ppat_or (_, _) | Ppat_alias (_, _) -> true
+ | _ -> false
+ in
+ let renderedPattern =
+ let p = printPattern p cmtTbl in
+ if needsParens then
+ Doc.concat [Doc.text "("; p; Doc.text ")"]
+ else
+ p
+ in
+ Doc.concat([
+ renderedPattern;
+ Doc.text " as ";
+ printStringLoc aliasLoc cmtTbl;
+ ])
+
+ (* Note: module(P : S) is represented as *)
+ (* Ppat_constraint(Ppat_unpack, Ptyp_package) *)
+ | Ppat_constraint ({ppat_desc = Ppat_unpack stringLoc}, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) ->
+ Doc.concat [
+ Doc.text "module(";
+ printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc;
+ Doc.text ": ";
+ printComments
+ (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl)
+ cmtTbl
+ ptyp_loc;
+ Doc.rparen;
+ ]
+ | Ppat_constraint (pattern, typ) ->
+ Doc.concat [
+ printPattern pattern cmtTbl;
+ Doc.text ": ";
+ printTypExpr typ cmtTbl;
+ ]
+
+ (* Note: module(P : S) is represented as *)
+ (* Ppat_constraint(Ppat_unpack, Ptyp_package) *)
+ | Ppat_unpack stringLoc ->
+ Doc.concat [
+ Doc.text "module(";
+ printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc;
+ Doc.rparen;
+ ]
+ | Ppat_interval (a, b) ->
+ Doc.concat [
+ printConstant a;
+ Doc.text " .. ";
+ printConstant b;
+ ]
+ | Ppat_open _ -> Doc.nil
+ in
+ let doc = match p.ppat_attributes with
+ | [] -> patternWithoutAttributes
+ | attrs ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ patternWithoutAttributes;
+ ]
+ )
+ in
+ printComments doc cmtTbl p.ppat_loc
+
+and printPatternRecordRow row cmtTbl =
+ match row with
+ (* punned {x}*)
+ | ({Location.txt=Longident.Lident ident} as longident,
+ {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt ->
+ printLidentPath longident cmtTbl
+ | (longident, pattern) ->
+ let locForComments = {
+ longident.loc with
+ loc_end = pattern.Parsetree.ppat_loc.loc_end
+ } in
+ let rhsDoc =
+ let doc = printPattern pattern cmtTbl in
+ if Parens.patternRecordRowRhs pattern then
+ addParens doc
+ else
+ doc
+ in
+ let doc = Doc.group (
+ Doc.concat([
+ printLidentPath longident cmtTbl;
+ Doc.text ":";
+ (if ParsetreeViewer.isHuggablePattern pattern then
+ Doc.concat [Doc.space; rhsDoc]
+ else
+ Doc.indent(
+ Doc.concat [
+ Doc.line;
+ rhsDoc;
+ ]
+ )
+ );
+ ])
+ ) in
+ printComments doc cmtTbl locForComments
+
+and printExpressionWithComments expr cmtTbl =
+ let doc = printExpression expr cmtTbl in
+ printComments doc cmtTbl expr.Parsetree.pexp_loc
+
+and printIfChain pexp_attributes ifs elseExpr cmtTbl =
+ let ifDocs = Doc.join ~sep:Doc.space (
+ List.mapi (fun i (ifExpr, thenExpr) ->
+ let ifTxt = if i > 0 then Doc.text "else if " else Doc.text "if " in
+ match ifExpr with
+ | ParsetreeViewer.If ifExpr ->
+ let condition =
+ if ParsetreeViewer.isBlockExpr ifExpr then
+ printExpressionBlock ~braces:true ifExpr cmtTbl
+ else
+ let doc = printExpressionWithComments ifExpr cmtTbl in
+ match Parens.expr ifExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc ifExpr braces
+ | Nothing -> Doc.ifBreaks (addParens doc) doc
+ in
+ Doc.concat [
+ ifTxt;
+ Doc.group (condition);
+ Doc.space;
+ let thenExpr = match ParsetreeViewer.processBracesAttr thenExpr with
+ (* This case only happens when coming from Reason, we strip braces *)
+ | (Some _, expr) -> expr
+ | _ -> thenExpr
+ in
+ printExpressionBlock ~braces:true thenExpr cmtTbl;
+ ]
+ | IfLet (pattern, conditionExpr) ->
+ let conditionDoc =
+ let doc = printExpressionWithComments conditionExpr cmtTbl in
+ match Parens.expr conditionExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc conditionExpr braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ ifTxt;
+ Doc.text "let ";
+ printPattern pattern cmtTbl;
+ Doc.text " = ";
+ conditionDoc;
+ Doc.space;
+ printExpressionBlock ~braces:true thenExpr cmtTbl;
+ ]
+ ) ifs
+ ) in
+ let elseDoc = match elseExpr with
+ | None -> Doc.nil
+ | Some expr -> Doc.concat [
+ Doc.text " else ";
+ printExpressionBlock ~braces:true expr cmtTbl;
+ ]
+ in
+ let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ ifDocs;
+ elseDoc;
+ ]
+
+and printExpression (e : Parsetree.expression) cmtTbl =
+ let printedExpression = match e.pexp_desc with
+ | Parsetree.Pexp_constant c ->
+ printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c
+ | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes ->
+ printJsxFragment e cmtTbl
+ | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()"
+ | Pexp_construct ({txt = Longident.Lident "[]"}, _) ->
+ Doc.concat [
+ Doc.text "list{";
+ printCommentsInside cmtTbl e.pexp_loc;
+ Doc.rbrace;
+ ]
+ | Pexp_construct ({txt = Longident.Lident "::"}, _) ->
+ let (expressions, spread) = ParsetreeViewer.collectListExpressions e in
+ let spreadDoc = match spread with
+ | Some(expr) -> Doc.concat [
+ Doc.text ",";
+ Doc.line;
+ Doc.dotdotdot;
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ ]
+ | None -> Doc.nil
+ in
+ Doc.group(
+ Doc.concat([
+ Doc.text "list{";
+ Doc.indent (
+ Doc.concat([
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map
+ (fun expr ->
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ )
+ expressions);
+ spreadDoc;
+ ])
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ])
+ )
+ | Pexp_construct (longidentLoc, args) ->
+ let constr = printLongidentLocation longidentLoc cmtTbl in
+ let args = match args with
+ | None -> Doc.nil
+ | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) ->
+ Doc.text "()"
+ (* Some((1, 2)) *)
+ | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) ->
+ Doc.concat [
+ Doc.lparen;
+ (let doc = printExpressionWithComments arg cmtTbl in
+ match Parens.expr arg with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc arg braces
+ | Nothing -> doc);
+ Doc.rparen;
+ ]
+ | Some({pexp_desc = Pexp_tuple args }) ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map
+ (fun expr ->
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc)
+ args
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ | Some(arg) ->
+ let argDoc =
+ let doc = printExpressionWithComments arg cmtTbl in
+ match Parens.expr arg with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc arg braces
+ | Nothing -> doc
+ in
+ let shouldHug = ParsetreeViewer.isHuggableExpression arg in
+ Doc.concat [
+ Doc.lparen;
+ if shouldHug then argDoc
+ else Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ argDoc;
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ ];
+ Doc.rparen;
+ ]
+ in
+ Doc.group(Doc.concat [constr; args])
+ | Pexp_ident path ->
+ printLidentPath path cmtTbl
+ | Pexp_tuple exprs ->
+ Doc.group(
+ Doc.concat([
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat([
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun expr ->
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc)
+ exprs)
+ ])
+ );
+ Doc.ifBreaks (Doc.text ",") Doc.nil;
+ Doc.softLine;
+ Doc.rparen;
+ ])
+ )
+ | Pexp_array [] ->
+ Doc.concat [
+ Doc.lbracket;
+ printCommentsInside cmtTbl e.pexp_loc;
+ Doc.rbracket;
+ ]
+ | Pexp_array exprs ->
+ Doc.group(
+ Doc.concat([
+ Doc.lbracket;
+ Doc.indent (
+ Doc.concat([
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun expr ->
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ ) exprs)
+ ])
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbracket;
+ ])
+ )
+ | Pexp_variant (label, args) ->
+ let variantName =
+ Doc.concat [Doc.text "#"; printPolyVarIdent label] in
+ let args = match args with
+ | None -> Doc.nil
+ | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) ->
+ Doc.text "()"
+ (* #poly((1, 2) *)
+ | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) ->
+ Doc.concat [
+ Doc.lparen;
+ (let doc = printExpressionWithComments arg cmtTbl in
+ match Parens.expr arg with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc arg braces
+ | Nothing -> doc);
+ Doc.rparen;
+ ]
+ | Some({pexp_desc = Pexp_tuple args }) ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map
+ (fun expr ->
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc)
+ args
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ | Some(arg) ->
+ let argDoc =
+ let doc = printExpressionWithComments arg cmtTbl in
+ match Parens.expr arg with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc arg braces
+ | Nothing -> doc
+ in
+ let shouldHug = ParsetreeViewer.isHuggableExpression arg in
+ Doc.concat [
+ Doc.lparen;
+ if shouldHug then argDoc
+ else Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ argDoc;
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ ];
+ Doc.rparen;
+ ]
+ in
+ Doc.group(Doc.concat [variantName; args])
+ | Pexp_record (rows, spreadExpr) ->
+ let spread = match spreadExpr with
+ | None -> Doc.nil
+ | Some expr -> Doc.concat [
+ Doc.dotdotdot;
+ (let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc);
+ Doc.comma;
+ Doc.line;
+ ]
+ in
+ (* If the record is written over multiple lines, break automatically
+ * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded
+ * `let x = {
+ * a: 1,
+ * b: 2,
+ * }` -> record is written on multiple lines, break the group *)
+ let forceBreak =
+ e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum
+ in
+ Doc.breakableGroup ~forceBreak (
+ Doc.concat([
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ spread;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun row -> printRecordRow row cmtTbl) rows)
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ])
+ )
+ | Pexp_extension extension ->
+ begin match extension with
+ | (
+ {txt = "bs.obj" | "obj"},
+ PStr [{
+ pstr_loc = loc;
+ pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, [])
+ }]
+ ) ->
+ (* If the object is written over multiple lines, break automatically
+ * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded
+ * `let x = {
+ * "a": 1,
+ * "b": 2,
+ * }` -> object is written on multiple lines, break the group *)
+ let forceBreak =
+ loc.loc_start.pos_lnum < loc.loc_end.pos_lnum
+ in
+ Doc.breakableGroup ~forceBreak (
+ Doc.concat([
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line])
+ (List.map (fun row -> printBsObjectRow row cmtTbl) rows)
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ])
+ )
+ | extension ->
+ printExtension ~atModuleLvl:false extension cmtTbl
+ end
+ | Pexp_apply _ ->
+ if ParsetreeViewer.isUnaryExpression e then
+ printUnaryExpression e cmtTbl
+ else if ParsetreeViewer.isTemplateLiteral e then
+ printTemplateLiteral e cmtTbl
+ else if ParsetreeViewer.isBinaryExpression e then
+ printBinaryExpression e cmtTbl
+ else
+ printPexpApply e cmtTbl
+ | Pexp_unreachable -> Doc.dot
+ | Pexp_field (expr, longidentLoc) ->
+ let lhs =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.fieldExpr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ lhs;
+ Doc.dot;
+ printLidentPath longidentLoc cmtTbl;
+ ]
+ | Pexp_setfield (expr1, longidentLoc, expr2) ->
+ printSetFieldExpr e.pexp_attributes expr1 longidentLoc expr2 e.pexp_loc cmtTbl
+ | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) when ParsetreeViewer.isTernaryExpr e ->
+ let (parts, alternate) = ParsetreeViewer.collectTernaryParts e in
+ let ternaryDoc = match parts with
+ | (condition1, consequent1)::rest ->
+ Doc.group (Doc.concat [
+ printTernaryOperand condition1 cmtTbl;
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ Doc.indent (
+ Doc.concat [
+ Doc.text "? ";
+ printTernaryOperand consequent1 cmtTbl
+ ]
+ );
+ Doc.concat (
+ List.map (fun (condition, consequent) ->
+ Doc.concat [
+ Doc.line;
+ Doc.text ": ";
+ printTernaryOperand condition cmtTbl;
+ Doc.line;
+ Doc.text "? ";
+ printTernaryOperand consequent cmtTbl;
+ ]
+ ) rest
+ );
+ Doc.line;
+ Doc.text ": ";
+ Doc.indent (printTernaryOperand alternate cmtTbl);
+ ]
+ )
+ ])
+ | _ -> Doc.nil
+ in
+ let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in
+ let needsParens = match ParsetreeViewer.filterParsingAttrs attrs with
+ | [] -> false | _ -> true
+ in
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ if needsParens then addParens ternaryDoc else ternaryDoc;
+ ]
+ | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) ->
+ let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in
+ printIfChain e.pexp_attributes ifs elseExpr cmtTbl
+ | Pexp_while (expr1, expr2) ->
+ let condition =
+ let doc = printExpressionWithComments expr1 cmtTbl in
+ match Parens.expr expr1 with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr1 braces
+ | Nothing -> doc
+ in
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.text "while ";
+ if ParsetreeViewer.isBlockExpr expr1 then
+ condition
+ else
+ Doc.group (
+ Doc.ifBreaks (addParens condition) condition
+ );
+ Doc.space;
+ printExpressionBlock ~braces:true expr2 cmtTbl;
+ ]
+ )
+ | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) ->
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.text "for ";
+ printPattern pattern cmtTbl;
+ Doc.text " in ";
+ (let doc = printExpressionWithComments fromExpr cmtTbl in
+ match Parens.expr fromExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc fromExpr braces
+ | Nothing -> doc);
+ printDirectionFlag directionFlag;
+ (let doc = printExpressionWithComments toExpr cmtTbl in
+ match Parens.expr toExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc toExpr braces
+ | Nothing -> doc);
+ Doc.space;
+ printExpressionBlock ~braces:true body cmtTbl;
+ ]
+ )
+ | Pexp_constraint(
+ {pexp_desc = Pexp_pack modExpr},
+ {ptyp_desc = Ptyp_package packageType; ptyp_loc}
+ ) ->
+ Doc.group (
+ Doc.concat [
+ Doc.text "module(";
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ printModExpr modExpr cmtTbl;
+ Doc.text ": ";
+ printComments
+ (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl)
+ cmtTbl
+ ptyp_loc
+ ]
+ );
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+
+ | Pexp_constraint (expr, typ) ->
+ let exprDoc =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ exprDoc;
+ Doc.text ": ";
+ printTypExpr typ cmtTbl;
+ ]
+ | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) ->
+ printExpressionBlock ~braces:true e cmtTbl
+ | Pexp_letexception (_extensionConstructor, _expr) ->
+ printExpressionBlock ~braces:true e cmtTbl
+ | Pexp_assert expr ->
+ let rhs =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.lazyOrAssertExprRhs expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ Doc.text "assert ";
+ rhs;
+ ]
+ | Pexp_lazy expr ->
+ let rhs =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.lazyOrAssertExprRhs expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.text "lazy ";
+ rhs;
+ ]
+ )
+ | Pexp_open (_overrideFlag, _longidentLoc, _expr) ->
+ printExpressionBlock ~braces:true e cmtTbl
+ | Pexp_pack (modExpr) ->
+ Doc.group (Doc.concat [
+ Doc.text "module(";
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ printModExpr modExpr cmtTbl;
+ ]
+ );
+ Doc.softLine;
+ Doc.rparen;
+ ])
+ | Pexp_sequence _ ->
+ printExpressionBlock ~braces:true e cmtTbl
+ | Pexp_let _ ->
+ printExpressionBlock ~braces:true e cmtTbl
+ | Pexp_fun (Nolabel, None, {ppat_desc = Ppat_var {txt="__x"}}, ({pexp_desc = Pexp_apply _})) ->
+ (* (__x) => f(a, __x, c) -----> f(a, _, c) *)
+ printExpressionWithComments (ParsetreeViewer.rewriteUnderscoreApply e) cmtTbl
+ | Pexp_fun _ | Pexp_newtype _ ->
+ let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in
+ let (uncurried, attrs) =
+ ParsetreeViewer.processUncurriedAttribute attrsOnArrow
+ in
+ let (returnExpr, typConstraint) = match returnExpr.pexp_desc with
+ | Pexp_constraint (expr, typ) -> (
+ {expr with pexp_attributes = List.concat [
+ expr.pexp_attributes;
+ returnExpr.pexp_attributes;
+ ]},
+ Some typ
+ )
+ | _ -> (returnExpr, None)
+ in
+ let hasConstraint = match typConstraint with | Some _ -> true | None -> false in
+ let parametersDoc = printExprFunParameters
+ ~inCallback:NoCallback
+ ~uncurried
+ ~hasConstraint
+ parameters
+ cmtTbl
+ in
+ let returnExprDoc =
+ let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in
+ let shouldInline = match (returnExpr.pexp_desc, optBraces) with
+ | (_, Some _ ) -> true
+ | ((Pexp_array _
+ | Pexp_tuple _
+ | Pexp_construct (_, Some _)
+ | Pexp_record _), _) -> true
+ | _ -> false
+ in
+ let shouldIndent = match returnExpr.pexp_desc with
+ | Pexp_sequence _
+ | Pexp_let _
+ | Pexp_letmodule _
+ | Pexp_letexception _
+ | Pexp_open _ -> false
+ | _ -> true
+ in
+ let returnDoc =
+ let doc = printExpressionWithComments returnExpr cmtTbl in
+ match Parens.expr returnExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc returnExpr braces
+ | Nothing -> doc
+ in
+ if shouldInline then Doc.concat [
+ Doc.space;
+ returnDoc;
+ ] else
+ Doc.group (
+ if shouldIndent then
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ returnDoc;
+ ]
+ )
+ else
+ Doc.concat [
+ Doc.space;
+ returnDoc
+ ]
+ )
+ in
+ let typConstraintDoc = match typConstraint with
+ | Some(typ) ->
+ let typDoc =
+ let doc = printTypExpr typ cmtTbl in
+ if Parens.arrowReturnTypExpr typ then
+ addParens doc
+ else
+ doc
+ in
+ Doc.concat [Doc.text ": "; typDoc]
+ | _ -> Doc.nil
+ in
+ let attrs = printAttributes attrs cmtTbl in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ parametersDoc;
+ typConstraintDoc;
+ Doc.text " =>";
+ returnExprDoc;
+ ]
+ )
+ | Pexp_try (expr, cases) ->
+ let exprDoc =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ Doc.text "try ";
+ exprDoc;
+ Doc.text " catch ";
+ printCases cases cmtTbl;
+ ]
+ | Pexp_match (_, [_;_]) when ParsetreeViewer.isIfLetExpr e ->
+ let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in
+ printIfChain e.pexp_attributes ifs elseExpr cmtTbl
+ | Pexp_match (expr, cases) ->
+ let exprDoc =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ Doc.text "switch ";
+ exprDoc;
+ Doc.space;
+ printCases cases cmtTbl;
+ ]
+ | Pexp_function cases ->
+ Doc.concat [
+ Doc.text "x => switch x ";
+ printCases cases cmtTbl;
+ ]
+ | Pexp_coerce (expr, typOpt, typ) ->
+ let docExpr = printExpressionWithComments expr cmtTbl in
+ let docTyp = printTypExpr typ cmtTbl in
+ let ofType = match typOpt with
+ | None -> Doc.nil
+ | Some(typ1) ->
+ Doc.concat [Doc.text ": "; printTypExpr typ1 cmtTbl]
+ in
+ Doc.concat [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen]
+ | Pexp_send (parentExpr, label) ->
+ let parentDoc =
+ let doc = printExpressionWithComments parentExpr cmtTbl in
+ match Parens.unaryExprOperand parentExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc parentExpr braces
+ | Nothing -> doc
+ in
+ let member =
+ let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in
+ Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""]
+ in
+ Doc.group (
+ Doc.concat [
+ parentDoc;
+ Doc.lbracket;
+ member;
+ Doc.rbracket;
+ ]
+ )
+ | Pexp_new _ ->
+ Doc.text "Pexp_new not impemented in printer"
+ | Pexp_setinstvar _ ->
+ Doc.text "Pexp_setinstvar not impemented in printer"
+ | Pexp_override _ ->
+ Doc.text "Pexp_override not impemented in printer"
+ | Pexp_poly _ ->
+ Doc.text "Pexp_poly not impemented in printer"
+ | Pexp_object _ ->
+ Doc.text "Pexp_object not impemented in printer"
+ in
+ let shouldPrintItsOwnAttributes = match e.pexp_desc with
+ | Pexp_apply _
+ | Pexp_fun _
+ | Pexp_newtype _
+ | Pexp_setfield _
+ | Pexp_ifthenelse _ -> true
+ | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true
+ | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> true
+ | _ -> false
+ in
+ match e.pexp_attributes with
+ | [] -> printedExpression
+ | attrs when not shouldPrintItsOwnAttributes ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ printedExpression;
+ ]
+ )
+ | _ -> printedExpression
+
+and printPexpFun ~inCallback e cmtTbl =
+ let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in
+ let (uncurried, attrs) =
+ ParsetreeViewer.processUncurriedAttribute attrsOnArrow
+ in
+ let (returnExpr, typConstraint) = match returnExpr.pexp_desc with
+ | Pexp_constraint (expr, typ) -> (
+ {expr with pexp_attributes = List.concat [
+ expr.pexp_attributes;
+ returnExpr.pexp_attributes;
+ ]},
+ Some typ
+ )
+ | _ -> (returnExpr, None)
+ in
+ let parametersDoc = printExprFunParameters
+ ~inCallback
+ ~uncurried
+ ~hasConstraint:(match typConstraint with | Some _ -> true | None -> false)
+ parameters cmtTbl in
+ let returnShouldIndent = match returnExpr.pexp_desc with
+ | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> false
+ | _ -> true
+ in
+ let returnExprDoc =
+ let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in
+ let shouldInline = match (returnExpr.pexp_desc, optBraces) with
+ | (_, Some _) -> true
+ | ((Pexp_array _
+ | Pexp_tuple _
+ | Pexp_construct (_, Some _)
+ | Pexp_record _), _) -> true
+ | _ -> false
+ in
+ let returnDoc =
+ let doc = printExpressionWithComments returnExpr cmtTbl in
+ match Parens.expr returnExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc returnExpr braces
+ | Nothing -> doc
+ in
+ if shouldInline then Doc.concat [
+ Doc.space;
+ returnDoc;
+ ] else
+ Doc.group (
+ if returnShouldIndent then
+ Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ returnDoc;
+ ]
+ );
+ (match inCallback with
+ | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine
+ | _ -> Doc.nil);
+ ]
+ else
+ Doc.concat [
+ Doc.space;
+ returnDoc;
+ ]
+ )
+ in
+ let typConstraintDoc = match typConstraint with
+ | Some(typ) -> Doc.concat [
+ Doc.text ": ";
+ printTypExpr typ cmtTbl
+ ]
+ | _ -> Doc.nil
+ in
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ parametersDoc;
+ typConstraintDoc;
+ Doc.text " =>";
+ returnExprDoc;
+ ]
+
+and printTernaryOperand expr cmtTbl =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.ternaryOperand expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+
+and printSetFieldExpr attrs lhs longidentLoc rhs loc cmtTbl =
+ let rhsDoc =
+ let doc = printExpressionWithComments rhs cmtTbl in
+ match Parens.setFieldExprRhs rhs with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc rhs braces
+ | Nothing -> doc
+ in
+ let lhsDoc =
+ let doc = printExpressionWithComments lhs cmtTbl in
+ match Parens.fieldExpr lhs with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc lhs braces
+ | Nothing -> doc
+ in
+ let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in
+ let doc = Doc.group (Doc.concat [
+ lhsDoc;
+ Doc.dot;
+ printLidentPath longidentLoc cmtTbl;
+ Doc.text " =";
+ if shouldIndent then Doc.group (
+ Doc.indent (
+ (Doc.concat [Doc.line; rhsDoc])
+ )
+ ) else
+ Doc.concat [Doc.space; rhsDoc]
+ ]) in
+ let doc = match attrs with
+ | [] -> doc
+ | attrs ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ doc
+ ]
+ )
+ in
+ printComments doc cmtTbl loc
+
+and printTemplateLiteral expr cmtTbl =
+ let tag = ref "js" in
+ let rec walkExpr expr =
+ let open Parsetree in
+ match expr.pexp_desc with
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}},
+ [Nolabel, arg1; Nolabel, arg2]
+ ) ->
+ let lhs = walkExpr arg1 in
+ let rhs = walkExpr arg2 in
+ Doc.concat [lhs; rhs]
+ | Pexp_constant (Pconst_string (txt, Some prefix)) ->
+ tag := prefix;
+ printStringContents txt
+ | _ ->
+ let doc = printExpressionWithComments expr cmtTbl in
+ Doc.group (
+ Doc.concat [
+ Doc.text "${";
+ Doc.indent doc;
+ Doc.rbrace;
+ ]
+ )
+ in
+ let content = walkExpr expr in
+ Doc.concat [
+ if !tag = "js" then Doc.nil else Doc.text !tag;
+ Doc.text "`";
+ content;
+ Doc.text "`"
+ ]
+
+and printUnaryExpression expr cmtTbl =
+ let printUnaryOperator op = Doc.text (
+ match op with
+ | "~+" -> "+"
+ | "~+." -> "+."
+ | "~-" -> "-"
+ | "~-." -> "-."
+ | "not" -> "!"
+ | _ -> assert false
+ ) in
+ match expr.pexp_desc with
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident operator}},
+ [Nolabel, operand]
+ ) ->
+ let printedOperand =
+ let doc = printExpressionWithComments operand cmtTbl in
+ match Parens.unaryExprOperand operand with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc operand braces
+ | Nothing -> doc
+ in
+ let doc = Doc.concat [
+ printUnaryOperator operator;
+ printedOperand;
+ ] in
+ printComments doc cmtTbl expr.pexp_loc
+ | _ -> assert false
+
+and printBinaryExpression (expr : Parsetree.expression) cmtTbl =
+ let printBinaryOperator ~inlineRhs operator =
+ let operatorTxt = match operator with
+ | "|." -> "->"
+ | "^" -> "++"
+ | "=" -> "=="
+ | "==" -> "==="
+ | "<>" -> "!="
+ | "!=" -> "!=="
+ | txt -> txt
+ in
+ let spacingBeforeOperator =
+ if operator = "|." then Doc.softLine
+ else if operator = "|>" then Doc.line
+ else Doc.space;
+ in
+ let spacingAfterOperator =
+ if operator = "|." then Doc.nil
+ else if operator = "|>" then Doc.space
+ else if inlineRhs then Doc.space else Doc.line
+ in
+ Doc.concat [
+ spacingBeforeOperator;
+ Doc.text operatorTxt;
+ spacingAfterOperator;
+ ]
+ in
+ let printOperand ~isLhs expr parentOperator =
+ let rec flatten ~isLhs expr parentOperator =
+ if ParsetreeViewer.isBinaryExpression expr then
+ begin match expr with
+ | {pexp_desc = Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident operator}},
+ [_, left; _, right]
+ )} ->
+ if ParsetreeViewer.flattenableOperators parentOperator operator &&
+ not (ParsetreeViewer.hasAttributes expr.pexp_attributes)
+ then
+ let leftPrinted = flatten ~isLhs:true left operator in
+ let rightPrinted =
+ let (_, rightAttrs) =
+ ParsetreeViewer.partitionPrinteableAttributes right.pexp_attributes
+ in
+ let doc =
+ printExpressionWithComments
+ {right with pexp_attributes = rightAttrs}
+ cmtTbl
+ in
+ let doc = if Parens.flattenOperandRhs parentOperator right then
+ Doc.concat [Doc.lparen; doc; Doc.rparen]
+ else
+ doc
+ in
+ let printeableAttrs =
+ ParsetreeViewer.filterPrinteableAttributes right.pexp_attributes
+ in
+ Doc.concat [printAttributes printeableAttrs cmtTbl; doc]
+ in
+ let doc = Doc.concat [
+ leftPrinted;
+ printBinaryOperator ~inlineRhs:false operator;
+ rightPrinted;
+ ] in
+ let doc =
+ if not isLhs && (Parens.rhsBinaryExprOperand operator expr) then
+ Doc.concat [Doc.lparen; doc; Doc.rparen]
+ else doc
+ in
+ printComments doc cmtTbl expr.pexp_loc
+ else (
+ let doc = printExpressionWithComments {expr with pexp_attributes = []} cmtTbl in
+ let doc = if Parens.subBinaryExprOperand parentOperator operator ||
+ (expr.pexp_attributes <> [] &&
+ (ParsetreeViewer.isBinaryExpression expr ||
+ ParsetreeViewer.isTernaryExpr expr))
+ then
+ Doc.concat [Doc.lparen; doc; Doc.rparen]
+ else doc
+ in Doc.concat [
+ printAttributes expr.pexp_attributes cmtTbl;
+ doc
+ ]
+ )
+ | _ -> assert false
+ end
+ else
+ begin match expr.pexp_desc with
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}},
+ [Nolabel, _; Nolabel, _]
+ ) when loc.loc_ghost ->
+ let doc = printTemplateLiteral expr cmtTbl in
+ printComments doc cmtTbl expr.Parsetree.pexp_loc
+ | Pexp_setfield (lhs, field, rhs) ->
+ let doc = printSetFieldExpr expr.pexp_attributes lhs field rhs expr.pexp_loc cmtTbl in
+ if isLhs then addParens doc else doc
+ | Pexp_apply(
+ {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}},
+ [(Nolabel, lhs); (Nolabel, rhs)]
+ ) ->
+ let rhsDoc = printExpressionWithComments rhs cmtTbl in
+ let lhsDoc = printExpressionWithComments lhs cmtTbl in
+ (* TODO: unify indentation of "=" *)
+ let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in
+ let doc = Doc.group (
+ Doc.concat [
+ lhsDoc;
+ Doc.text " =";
+ if shouldIndent then Doc.group (
+ Doc.indent (Doc.concat [Doc.line; rhsDoc])
+ ) else
+ Doc.concat [Doc.space; rhsDoc]
+ ]
+ ) in
+ let doc = match expr.pexp_attributes with
+ | [] -> doc
+ | attrs ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ doc
+ ]
+ )
+ in
+ if isLhs then addParens doc else doc
+ | _ ->
+ let doc = printExpressionWithComments expr cmtTbl in
+ begin match Parens.binaryExprOperand ~isLhs expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ end
+ end
+ in
+ flatten ~isLhs expr parentOperator
+ in
+ match expr.pexp_desc with
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}},
+ [Nolabel, lhs; Nolabel, rhs]
+ ) when not (
+ ParsetreeViewer.isBinaryExpression lhs ||
+ ParsetreeViewer.isBinaryExpression rhs
+ ) ->
+ let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in
+ let lhsDoc = printOperand ~isLhs:true lhs op in
+ let rhsDoc = printOperand ~isLhs:false rhs op in
+ Doc.group (
+ Doc.concat [
+ lhsDoc;
+ (match lhsHasCommentBelow, op with
+ | true, "|." -> Doc.concat [Doc.softLine; Doc.text "->"]
+ | false, "|." -> Doc.text "->"
+ | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "]
+ | false, "|>" -> Doc.text " |> "
+ | _ -> Doc.nil
+ );
+ rhsDoc;
+ ]
+ )
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident operator}},
+ [Nolabel, lhs; Nolabel, rhs]
+ ) ->
+ let right =
+ let operatorWithRhs =
+ let rhsDoc = printOperand ~isLhs:false rhs operator in
+ Doc.concat [
+ printBinaryOperator
+ ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) operator;
+ rhsDoc;
+ ] in
+ if ParsetreeViewer.shouldIndentBinaryExpr expr then
+ Doc.group (Doc.indent operatorWithRhs)
+ else operatorWithRhs
+ in
+ let doc = Doc.group (
+ Doc.concat [
+ printOperand ~isLhs:true lhs operator;
+ right
+ ]
+ ) in
+ Doc.group (
+ Doc.concat [
+ printAttributes expr.pexp_attributes cmtTbl;
+ match Parens.binaryExpr {expr with
+ pexp_attributes = List.filter (fun attr ->
+ match attr with
+ | ({Location.txt = ("ns.braces")}, _) -> false
+ | _ -> true
+ ) expr.pexp_attributes
+ } with
+ | Braced(bracesLoc) -> printBraces doc expr bracesLoc
+ | Parenthesized -> addParens doc
+ | Nothing -> doc;
+ ]
+ )
+ | _ -> Doc.nil
+
+(* callExpr(arg1, arg2) *)
+and printPexpApply expr cmtTbl =
+ match expr.pexp_desc with
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}},
+ [Nolabel, parentExpr; Nolabel, memberExpr]
+ ) ->
+ let parentDoc =
+ let doc = printExpressionWithComments parentExpr cmtTbl in
+ match Parens.unaryExprOperand parentExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc parentExpr braces
+ | Nothing -> doc
+ in
+ let member =
+ let memberDoc = match memberExpr.pexp_desc with
+ | Pexp_ident lident ->
+ printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc
+ | _ -> printExpressionWithComments memberExpr cmtTbl
+ in
+ Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""]
+ in
+ Doc.group (Doc.concat [
+ printAttributes expr.pexp_attributes cmtTbl;
+ parentDoc;
+ Doc.lbracket;
+ member;
+ Doc.rbracket;
+ ])
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}},
+ [Nolabel, lhs; Nolabel, rhs]
+ ) ->
+ let rhsDoc =
+ let doc = printExpressionWithComments rhs cmtTbl in
+ match Parens.expr rhs with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc rhs braces
+ | Nothing -> doc
+ in
+ (* TODO: unify indentation of "=" *)
+ let shouldIndent = not (ParsetreeViewer.isBracedExpr rhs) && ParsetreeViewer.isBinaryExpression rhs in
+ let doc = Doc.group(
+ Doc.concat [
+ printExpressionWithComments lhs cmtTbl;
+ Doc.text " =";
+ if shouldIndent then Doc.group (
+ Doc.indent (
+ (Doc.concat [Doc.line; rhsDoc])
+ )
+ ) else
+ Doc.concat [Doc.space; rhsDoc]
+ ]
+ ) in
+ begin match expr.pexp_attributes with
+ | [] -> doc
+ | attrs ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ doc
+ ]
+ )
+ end
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}},
+ [Nolabel, parentExpr; Nolabel, memberExpr]
+ ) when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) ->
+ (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *)
+ let member =
+ let memberDoc =
+ let doc = printExpressionWithComments memberExpr cmtTbl in
+ match Parens.expr memberExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc memberExpr braces
+ | Nothing -> doc
+ in
+ let shouldInline = match memberExpr.pexp_desc with
+ | Pexp_constant _ | Pexp_ident _ -> true
+ | _ -> false
+ in
+ if shouldInline then memberDoc else (
+ Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ memberDoc;
+ ]
+ );
+ Doc.softLine
+ ]
+ )
+ in
+ let parentDoc =
+ let doc = printExpressionWithComments parentExpr cmtTbl in
+ match Parens.unaryExprOperand parentExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc parentExpr braces
+ | Nothing -> doc
+ in
+ Doc.group (Doc.concat [
+ printAttributes expr.pexp_attributes cmtTbl;
+ parentDoc;
+ Doc.lbracket;
+ member;
+ Doc.rbracket;
+ ])
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}},
+ [Nolabel, parentExpr; Nolabel, memberExpr; Nolabel, targetExpr]
+ ) ->
+ let member =
+ let memberDoc =
+ let doc = printExpressionWithComments memberExpr cmtTbl in
+ match Parens.expr memberExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc memberExpr braces
+ | Nothing -> doc
+ in
+ let shouldInline = match memberExpr.pexp_desc with
+ | Pexp_constant _ | Pexp_ident _ -> true
+ | _ -> false
+ in
+ if shouldInline then memberDoc else (
+ Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ memberDoc;
+ ]
+ );
+ Doc.softLine
+ ]
+ )
+ in
+ let shouldIndentTargetExpr =
+ if ParsetreeViewer.isBracedExpr targetExpr then
+ false
+ else
+ ParsetreeViewer.isBinaryExpression targetExpr ||
+ (match targetExpr with
+ | {
+ pexp_attributes = [({Location.txt="ns.ternary"}, _)];
+ pexp_desc = Pexp_ifthenelse (ifExpr, _, _)
+ } ->
+ ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes
+ | { pexp_desc = Pexp_newtype _} -> false
+ | e ->
+ ParsetreeViewer.hasAttributes e.pexp_attributes ||
+ ParsetreeViewer.isArrayAccess e
+ )
+ in
+ let targetExpr =
+ let doc = printExpressionWithComments targetExpr cmtTbl in
+ match Parens.expr targetExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc targetExpr braces
+ | Nothing -> doc
+ in
+ let parentDoc =
+ let doc = printExpressionWithComments parentExpr cmtTbl in
+ match Parens.unaryExprOperand parentExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc parentExpr braces
+ | Nothing -> doc
+ in
+ Doc.group (
+ Doc.concat [
+ printAttributes expr.pexp_attributes cmtTbl;
+ parentDoc;
+ Doc.lbracket;
+ member;
+ Doc.rbracket;
+ Doc.text " =";
+ if shouldIndentTargetExpr then
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ targetExpr;
+ ]
+ )
+ else
+ Doc.concat [
+ Doc.space;
+ targetExpr;
+ ]
+ ]
+ )
+ (* TODO: cleanup, are those branches even remotely performant? *)
+ | Pexp_apply (
+ {pexp_desc = Pexp_ident lident},
+ args
+ ) when ParsetreeViewer.isJsxExpression expr ->
+ printJsxExpression lident args cmtTbl
+ | Pexp_apply (callExpr, args) ->
+ let args = List.map (fun (lbl, arg) ->
+ (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)
+ ) args
+ in
+ let (uncurried, attrs) =
+ ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes
+ in
+ let callExprDoc =
+ let doc = printExpressionWithComments callExpr cmtTbl in
+ match Parens.callExpr callExpr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc callExpr braces
+ | Nothing -> doc
+ in
+ if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then
+ let argsDoc =
+ printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl
+ in
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ callExprDoc;
+ argsDoc;
+ ]
+ else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then
+ let argsDoc =
+ printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl
+ in
+ (*
+ * Fixes the following layout (the `[` and `]` should break):
+ * [fn(x => {
+ * let _ = x
+ * }), fn(y => {
+ * let _ = y
+ * }), fn(z => {
+ * let _ = z
+ * })]
+ * See `Doc.willBreak documentation in interface file for more context.
+ * Context:
+ * https://github.com/rescript-lang/syntax/issues/111
+ * https://github.com/rescript-lang/syntax/issues/166
+ *)
+ let maybeBreakParent =
+ if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil
+ in
+ Doc.concat [
+ maybeBreakParent;
+ printAttributes attrs cmtTbl;
+ callExprDoc;
+ argsDoc;
+ ]
+ else
+ let argsDoc = printArguments ~uncurried args cmtTbl in
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ callExprDoc;
+ argsDoc;
+ ]
+ | _ -> assert false
+
+and printJsxExpression lident args cmtTbl =
+ let name = printJsxName lident in
+ let (formattedProps, children) = printJsxProps args cmtTbl in
+ (* *)
+ let isSelfClosing =
+ match children with
+ | Some ({Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)}) -> true
+ | _ -> false
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.group (
+ Doc.concat [
+ printComments (Doc.concat [Doc.lessThan; name]) cmtTbl lident.Asttypes.loc;
+ formattedProps;
+ if isSelfClosing then Doc.concat [Doc.line; Doc.text "/>"] else Doc.nil
+ ]
+ );
+ if isSelfClosing then Doc.nil
+ else
+ Doc.concat [
+ Doc.greaterThan;
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ (match children with
+ | Some childrenExpression -> printJsxChildren childrenExpression cmtTbl
+ | None -> Doc.nil
+ );
+ ]
+ );
+ Doc.line;
+ Doc.text "" in
+ let closing = Doc.text "" in
+ (* let (children, _) = ParsetreeViewer.collectListExpressions expr in *)
+ Doc.group (
+ Doc.concat [
+ opening;
+ begin match expr.pexp_desc with
+ | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil
+ | _ ->
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printJsxChildren expr cmtTbl;
+ ]
+ )
+ end;
+ Doc.line;
+ closing;
+ ]
+ )
+
+and printJsxChildren (childrenExpr : Parsetree.expression) cmtTbl =
+ match childrenExpr.pexp_desc with
+ | Pexp_construct ({txt = Longident.Lident "::"}, _) ->
+ let (children, _) = ParsetreeViewer.collectListExpressions childrenExpr in
+ Doc.group (
+ Doc.join ~sep:Doc.line (
+ List.map (fun (expr : Parsetree.expression) ->
+ let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in
+ let exprDoc = printExpressionWithComments expr cmtTbl in
+ match Parens.jsxChildExpr expr with
+ | Parenthesized | Braced _ ->
+ (* {(20: int)} make sure that we also protect the expression inside *)
+ let innerDoc = if Parens.bracedExpr expr then addParens exprDoc else exprDoc in
+ if leadingLineCommentPresent then
+ addBraces innerDoc
+ else
+ Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace]
+ | Nothing -> exprDoc
+ ) children
+ )
+ )
+ | _ ->
+ let leadingLineCommentPresent = hasLeadingLineComment cmtTbl childrenExpr.pexp_loc in
+ let exprDoc = printExpressionWithComments childrenExpr cmtTbl in
+ Doc.concat [
+ Doc.dotdotdot;
+ match Parens.jsxChildExpr childrenExpr with
+ | Parenthesized | Braced _ ->
+ let innerDoc = if Parens.bracedExpr childrenExpr then addParens exprDoc else exprDoc in
+ if leadingLineCommentPresent then
+ addBraces innerDoc
+ else
+ Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace]
+ | Nothing -> exprDoc
+ ]
+
+and printJsxProps args cmtTbl :(Doc.t * Parsetree.expression option) =
+ let rec loop props args =
+ match args with
+ | [] -> (Doc.nil, None)
+ | [
+ (Asttypes.Labelled "children", children);
+ (
+ Asttypes.Nolabel,
+ {Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)}
+ )
+ ] ->
+ let formattedProps = Doc.indent (
+ match props with
+ | [] -> Doc.nil
+ | props ->
+ Doc.concat [
+ Doc.line;
+ Doc.group (
+ Doc.join ~sep:Doc.line (props |> List.rev)
+ )
+ ]
+ ) in
+ (formattedProps, Some children)
+ | arg::args ->
+ let propDoc = printJsxProp arg cmtTbl in
+ loop (propDoc::props) args
+ in
+ loop [] args
+
+and printJsxProp arg cmtTbl =
+ match arg with
+ | (
+ (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl,
+ {
+ Parsetree.pexp_attributes = [({Location.txt = "ns.namedArgLoc"; loc = argLoc}, _)];
+ pexp_desc = Pexp_ident {txt = Longident.Lident ident}
+ }
+ ) when lblTxt = ident (* jsx punning *) ->
+ begin match lbl with
+ | Nolabel -> Doc.nil
+ | Labelled _lbl ->
+ printComments (printIdentLike ident) cmtTbl argLoc
+ | Optional _lbl ->
+ let doc = Doc.concat [
+ Doc.question;
+ printIdentLike ident;
+ ] in
+ printComments doc cmtTbl argLoc
+ end
+ | (
+ (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl,
+ {
+ Parsetree.pexp_attributes = [];
+ pexp_desc = Pexp_ident {txt = Longident.Lident ident}
+ }
+ ) when lblTxt = ident (* jsx punning when printing from Reason *) ->
+ begin match lbl with
+ | Nolabel -> Doc.nil
+ | Labelled _lbl -> printIdentLike ident
+ | Optional _lbl -> Doc.concat [
+ Doc.question;
+ printIdentLike ident;
+ ]
+ end
+ | (lbl, expr) ->
+ let (argLoc, expr) = match expr.pexp_attributes with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs ->
+ (loc, {expr with pexp_attributes = attrs})
+ | _ ->
+ Location.none, expr
+ in
+ let lblDoc = match lbl with
+ | Asttypes.Labelled lbl ->
+ let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in
+ Doc.concat [lbl; Doc.equal]
+ | Asttypes.Optional lbl ->
+ let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in
+ Doc.concat [lbl; Doc.equal; Doc.question]
+ | Nolabel -> Doc.nil
+ in
+ let exprDoc =
+ let leadingLineCommentPresent = hasLeadingLineComment cmtTbl expr.pexp_loc in
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.jsxPropExpr expr with
+ | Parenthesized | Braced(_) ->
+ (* {(20: int)} make sure that we also protect the expression inside *)
+ let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in
+ if leadingLineCommentPresent then
+ addBraces innerDoc
+ else
+ Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace]
+ | _ -> doc
+ in
+ let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in
+ printComments
+ (Doc.concat [
+ lblDoc;
+ exprDoc;
+ ])
+ cmtTbl
+ fullLoc
+
+(* div -> div.
+ * Navabar.createElement -> Navbar
+ * Staff.Users.createElement -> Staff.Users *)
+and printJsxName {txt = lident} =
+ let rec flatten acc lident = match lident with
+ | Longident.Lident txt -> txt::acc
+ | Ldot (lident, txt) ->
+ let acc = if txt = "createElement" then acc else txt::acc in
+ flatten acc lident
+ | _ -> acc
+ in
+ match lident with
+ | Longident.Lident txt -> Doc.text txt
+ | _ as lident ->
+ let segments = flatten [] lident in
+ Doc.join ~sep:Doc.dot (List.map Doc.text segments)
+
+and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl =
+ (* Because the same subtree gets printed twice, we need to copy the cmtTbl.
+ * consumed comments need to be marked not-consumed and reprinted…
+ * Cheng's different comment algorithm will solve this. *)
+ let cmtTblCopy = CommentTable.copy cmtTbl in
+ let (callback, printedArgs) = match args with
+ | (lbl, expr)::args ->
+ let lblDoc = match lbl with
+ | Asttypes.Nolabel -> Doc.nil
+ | Asttypes.Labelled txt ->
+ Doc.concat [
+ Doc.tilde; printIdentLike txt; Doc.equal;
+ ]
+ | Asttypes.Optional txt ->
+ Doc.concat [
+ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question;
+ ]
+ in
+ let callback = Doc.concat [
+ lblDoc;
+ printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl
+ ] in
+ let callback = printComments callback cmtTbl expr.pexp_loc in
+ let printedArgs =
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun arg -> printArgument arg cmtTbl) args
+ )
+ in
+ (callback, printedArgs)
+ | _ -> assert false
+ in
+
+ (* Thing.map((arg1, arg2) => MyModuleBlah.toList(argument), foo) *)
+ (* Thing.map((arg1, arg2) => {
+ * MyModuleBlah.toList(argument)
+ * }, longArgumet, veryLooooongArgument)
+ *)
+ let fitsOnOneLine = Doc.concat [
+ if uncurried then Doc.text "(. " else Doc.lparen;
+ callback;
+ Doc.comma;
+ Doc.line;
+ printedArgs;
+ Doc.rparen;
+ ] in
+
+ (* Thing.map(
+ * (param1, parm2) => doStuff(param1, parm2),
+ * arg1,
+ * arg2,
+ * arg3,
+ * )
+ *)
+ let breakAllArgs = printArguments ~uncurried args cmtTblCopy in
+
+ (* Sometimes one of the non-callback arguments will break.
+ * There might be a single line comment in there, or a multiline string etc.
+ * showDialog(
+ * ~onConfirm={() => ()},
+ * `
+ * Do you really want to leave this workspace?
+ * Some more text with detailed explanations...
+ * `,
+ * ~danger=true,
+ * // comment --> here a single line comment
+ * ~confirmText="Yes, I am sure!",
+ * )
+ * In this case, we always want the arguments broken over multiple lines,
+ * like a normal function call.
+ *)
+ if Doc.willBreak printedArgs then
+ breakAllArgs
+ else
+ Doc.customLayout [
+ fitsOnOneLine;
+ breakAllArgs;
+ ]
+
+and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl =
+ (* Because the same subtree gets printed twice, we need to copy the cmtTbl.
+ * consumed comments need to be marked not-consumed and reprinted…
+ * Cheng's different comment algorithm will solve this. *)
+ let cmtTblCopy = CommentTable.copy cmtTbl in
+ let cmtTblCopy2 = CommentTable.copy cmtTbl in
+ let rec loop acc args = match args with
+ | [] -> (Doc.nil, Doc.nil, Doc.nil)
+ | [lbl, expr] ->
+ let lblDoc = match lbl with
+ | Asttypes.Nolabel -> Doc.nil
+ | Asttypes.Labelled txt ->
+ Doc.concat [
+ Doc.tilde; printIdentLike txt; Doc.equal;
+ ]
+ | Asttypes.Optional txt ->
+ Doc.concat [
+ Doc.tilde; printIdentLike txt; Doc.equal; Doc.question;
+ ]
+ in
+ let callbackFitsOnOneLine =
+ let pexpFunDoc = printPexpFun ~inCallback:FitsOnOneLine expr cmtTbl in
+ let doc = Doc.concat [lblDoc; pexpFunDoc] in
+ printComments doc cmtTbl expr.pexp_loc
+ in
+ let callbackArgumentsFitsOnOneLine =
+ let pexpFunDoc = printPexpFun ~inCallback:ArgumentsFitOnOneLine expr cmtTblCopy in
+ let doc = Doc.concat [lblDoc; pexpFunDoc] in
+ printComments doc cmtTblCopy expr.pexp_loc
+ in
+ (
+ Doc.concat (List.rev acc),
+ callbackFitsOnOneLine,
+ callbackArgumentsFitsOnOneLine
+ )
+ | arg::args ->
+ let argDoc = printArgument arg cmtTbl in
+ loop (Doc.line::Doc.comma::argDoc::acc) args
+ in
+ let (printedArgs, callback, callback2) = loop [] args in
+
+ (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *)
+ let fitsOnOneLine = Doc.concat [
+ if uncurried then Doc.text "(." else Doc.lparen;
+ printedArgs;
+ callback;
+ Doc.rparen;
+ ] in
+
+ (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) =>
+ * MyModuleBlah.toList(argument)
+ * )
+ *)
+ let arugmentsFitOnOneLine =
+ Doc.concat [
+ if uncurried then Doc.text "(." else Doc.lparen;
+ printedArgs;
+ Doc.breakableGroup ~forceBreak:true callback2;
+ Doc.rparen;
+ ]
+ in
+
+ (* Thing.map(
+ * arg1,
+ * arg2,
+ * arg3,
+ * (param1, parm2) => doStuff(param1, parm2)
+ * )
+ *)
+ let breakAllArgs = printArguments ~uncurried args cmtTblCopy2 in
+
+ (* Sometimes one of the non-callback arguments will break.
+ * There might be a single line comment in there, or a multiline string etc.
+ * showDialog(
+ * `
+ * Do you really want to leave this workspace?
+ * Some more text with detailed explanations...
+ * `,
+ * ~danger=true,
+ * // comment --> here a single line comment
+ * ~confirmText="Yes, I am sure!",
+ * ~onConfirm={() => ()},
+ * )
+ * In this case, we always want the arguments broken over multiple lines,
+ * like a normal function call.
+ *)
+ if Doc.willBreak printedArgs then
+ breakAllArgs
+ else
+ Doc.customLayout [
+ fitsOnOneLine;
+ arugmentsFitOnOneLine;
+ breakAllArgs;
+ ]
+
+and printArguments ~uncurried (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl =
+ match args with
+ | [Nolabel, {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); pexp_loc = loc}] ->
+ (* See "parseCallExpr", ghost unit expression is used the implement
+ * arity zero vs arity one syntax.
+ * Related: https://github.com/rescript-lang/syntax/issues/138 *)
+ begin match uncurried, loc.loc_ghost with
+ | true, true -> Doc.text "(.)" (* arity zero *)
+ | true, false -> Doc.text "(. ())" (* arity one *)
+ | _ -> Doc.text "()"
+ end
+ | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg ->
+ let argDoc =
+ let doc = printExpressionWithComments arg cmtTbl in
+ match Parens.expr arg with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc arg braces
+ | Nothing -> doc
+ in
+ Doc.concat [
+ if uncurried then Doc.text "(. " else Doc.lparen;
+ argDoc;
+ Doc.rparen;
+ ]
+ | args -> Doc.group (
+ Doc.concat [
+ if uncurried then Doc.text "(." else Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ if uncurried then Doc.line else Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun arg -> printArgument arg cmtTbl) args
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+
+(*
+ * argument ::=
+ * | _ (* syntax sugar *)
+ * | expr
+ * | expr : type
+ * | ~ label-name
+ * | ~ label-name
+ * | ~ label-name ?
+ * | ~ label-name = expr
+ * | ~ label-name = _ (* syntax sugar *)
+ * | ~ label-name = expr : type
+ * | ~ label-name = ? expr
+ * | ~ label-name = ? _ (* syntax sugar *)
+ * | ~ label-name = ? expr : type *)
+and printArgument (argLbl, arg) cmtTbl =
+ match (argLbl, arg) with
+ (* ~a (punned)*)
+ | (
+ (Asttypes.Labelled lbl),
+ ({pexp_desc=Pexp_ident {txt = Longident.Lident name};
+ pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)])
+ } as argExpr)
+ ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) ->
+ let loc = match arg.pexp_attributes with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> loc
+ | _ -> arg.pexp_loc
+ in
+ let doc = Doc.concat [
+ Doc.tilde;
+ printIdentLike lbl
+ ] in
+ printComments doc cmtTbl loc
+
+ (* ~a: int (punned)*)
+ | (
+ (Asttypes.Labelled lbl),
+ {pexp_desc = Pexp_constraint (
+ {pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr,
+ typ
+ );
+ pexp_loc;
+ pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)]) as attrs
+ }
+ ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) ->
+ let loc = match attrs with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ ->
+ {loc with loc_end = pexp_loc.loc_end}
+ | _ -> arg.pexp_loc
+ in
+ let doc = Doc.concat [
+ Doc.tilde;
+ printIdentLike lbl;
+ Doc.text ": ";
+ printTypExpr typ cmtTbl;
+ ] in
+ printComments doc cmtTbl loc
+ (* ~a? (optional lbl punned)*)
+ | (
+ (Asttypes.Optional lbl),
+ {pexp_desc=Pexp_ident {txt = Longident.Lident name};
+ pexp_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)])
+ }
+ ) when lbl = name ->
+ let loc = match arg.pexp_attributes with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ -> loc
+ | _ -> arg.pexp_loc
+ in
+ let doc = Doc.concat [
+ Doc.tilde;
+ printIdentLike lbl;
+ Doc.question;
+ ] in
+ printComments doc cmtTbl loc
+ | (_lbl, expr) ->
+ let (argLoc, expr) = match expr.pexp_attributes with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::attrs ->
+ (loc, {expr with pexp_attributes = attrs})
+ | _ ->
+ expr.pexp_loc, expr
+ in
+ let printedLbl = match argLbl with
+ | Asttypes.Nolabel -> Doc.nil
+ | Asttypes.Labelled lbl ->
+ let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in
+ printComments doc cmtTbl argLoc
+ | Asttypes.Optional lbl ->
+ let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] in
+ printComments doc cmtTbl argLoc
+ in
+ let printedExpr =
+ let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in
+ let doc = Doc.concat [
+ printedLbl;
+ printedExpr;
+ ] in
+ printComments doc cmtTbl loc
+
+and printCases (cases: Parsetree.case list) cmtTbl =
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.concat [
+ Doc.line;
+ printList
+ ~getLoc:(fun n -> {n.Parsetree.pc_lhs.ppat_loc with
+ loc_end =
+ match ParsetreeViewer.processBracesAttr n.Parsetree.pc_rhs with
+ | (None, _) -> n.pc_rhs.pexp_loc.loc_end
+ | (Some ({loc}, _), _) -> loc.Location.loc_end
+ })
+ ~print:printCase
+ ~nodes:cases
+ cmtTbl
+ ];
+ Doc.line;
+ Doc.rbrace;
+ ]
+ )
+
+and printCase (case: Parsetree.case) cmtTbl =
+ let rhs = match case.pc_rhs.pexp_desc with
+ | Pexp_let _
+ | Pexp_letmodule _
+ | Pexp_letexception _
+ | Pexp_open _
+ | Pexp_sequence _ ->
+ printExpressionBlock ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) case.pc_rhs cmtTbl
+ | _ ->
+ let doc = printExpressionWithComments case.pc_rhs cmtTbl in
+ begin match Parens.expr case.pc_rhs with
+ | Parenthesized -> addParens doc
+ | _ -> doc
+ end
+
+ in
+ let guard = match case.pc_guard with
+ | None -> Doc.nil
+ | Some expr -> Doc.group (
+ Doc.concat [
+ Doc.line;
+ Doc.text "if ";
+ printExpressionWithComments expr cmtTbl;
+ ]
+ )
+ in
+ let shouldInlineRhs = match case.pc_rhs.pexp_desc with
+ | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _)
+ | Pexp_constant _
+ | Pexp_ident _ -> true
+ | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true
+ | _ -> false
+ in
+ let shouldIndentPattern = match case.pc_lhs.ppat_desc with
+ | Ppat_or _ -> false
+ | _ -> true
+ in
+ let patternDoc =
+ let doc = printPattern case.pc_lhs cmtTbl in
+ match case.pc_lhs.ppat_desc with
+ | Ppat_constraint _ -> addParens doc
+ | _ -> doc
+ in
+ let content = Doc.concat [
+ if shouldIndentPattern then Doc.indent patternDoc else patternDoc;
+ Doc.indent guard;
+ Doc.text " =>";
+ Doc.indent (
+ Doc.concat [
+ if shouldInlineRhs then Doc.space else Doc.line;
+ rhs;
+ ]
+ )
+ ] in
+ Doc.group (
+ Doc.concat [
+ Doc.text "| ";
+ content;
+ ]
+ )
+
+and printExprFunParameters ~inCallback ~uncurried ~hasConstraint parameters cmtTbl =
+ match parameters with
+ (* let f = _ => () *)
+ | [ParsetreeViewer.Parameter {
+ attrs = [];
+ lbl = Asttypes.Nolabel;
+ defaultExpr = None;
+ pat = {Parsetree.ppat_desc = Ppat_any}
+ }] when not uncurried ->
+ if hasConstraint then Doc.text "(_)" else Doc.text "_"
+ (* let f = a => () *)
+ | [ParsetreeViewer.Parameter {
+ attrs = [];
+ lbl = Asttypes.Nolabel;
+ defaultExpr = None;
+ pat = {Parsetree.ppat_desc = Ppat_var stringLoc}
+ }] when not uncurried ->
+ let txtDoc =
+ let var = printIdentLike stringLoc.txt in
+ if hasConstraint then addParens var else var
+ in
+ printComments txtDoc cmtTbl stringLoc.loc
+ (* let f = () => () *)
+ | [ParsetreeViewer.Parameter {
+ attrs = [];
+ lbl = Asttypes.Nolabel;
+ defaultExpr = None;
+ pat = {ppat_desc = Ppat_construct({txt = Longident.Lident "()"}, None)}
+ }] when not uncurried ->
+ Doc.text "()"
+ (* let f = (~greeting, ~from as hometown, ~x=?) => () *)
+ | parameters ->
+ let inCallback = match inCallback with
+ | FitsOnOneLine -> true
+ | _ -> false
+ in
+ let lparen = if uncurried then Doc.text "(. " else Doc.lparen in
+ let shouldHug = ParsetreeViewer.parametersShouldHug parameters in
+ let printedParamaters = Doc.concat [
+ if shouldHug || inCallback then Doc.nil else Doc.softLine;
+ Doc.join
+ ~sep:(Doc.concat [Doc.comma; Doc.line])
+ (List.map (fun p -> printExpFunParameter p cmtTbl) parameters)
+ ] in
+ Doc.group (
+ Doc.concat [
+ lparen;
+ if shouldHug || inCallback then
+ printedParamaters
+ else
+ Doc.concat [
+ Doc.indent printedParamaters;
+ Doc.trailingComma;
+ Doc.softLine;
+ ];
+ Doc.rparen;
+ ]
+ )
+
+and printExpFunParameter parameter cmtTbl =
+ match parameter with
+ | ParsetreeViewer.NewTypes {attrs; locs = lbls} ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ Doc.text "type ";
+ Doc.join ~sep:Doc.space (List.map (fun lbl ->
+ printComments (printIdentLike lbl.Asttypes.txt) cmtTbl lbl.Asttypes.loc
+ ) lbls)
+ ]
+ )
+ | Parameter {attrs; lbl; defaultExpr; pat = pattern} ->
+ let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in
+ let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in
+ let attrs = printAttributes attrs cmtTbl in
+ (* =defaultValue *)
+ let defaultExprDoc = match defaultExpr with
+ | Some expr -> Doc.concat [
+ Doc.text "=";
+ printExpressionWithComments expr cmtTbl
+ ]
+ | None -> Doc.nil
+ in
+ (* ~from as hometown
+ * ~from -> punning *)
+ let labelWithPattern = match (lbl, pattern) with
+ | (Asttypes.Nolabel, pattern) -> printPattern pattern cmtTbl
+ | (
+ (Asttypes.Labelled lbl | Optional lbl),
+ {ppat_desc = Ppat_var stringLoc;
+ ppat_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)])
+ }
+ ) when lbl = stringLoc.txt ->
+ (* ~d *)
+ Doc.concat [
+ Doc.text "~";
+ printIdentLike lbl;
+ ]
+ | (
+ (Asttypes.Labelled lbl | Optional lbl),
+ ({ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ);
+ ppat_attributes = ([] | [({Location.txt = "ns.namedArgLoc";}, _)])
+ })
+ ) when lbl = txt ->
+ (* ~d: e *)
+ Doc.concat [
+ Doc.text "~";
+ printIdentLike lbl;
+ Doc.text ": ";
+ printTypExpr typ cmtTbl;
+ ]
+ | ((Asttypes.Labelled lbl | Optional lbl), pattern) ->
+ (* ~b as c *)
+ Doc.concat [
+ Doc.text "~";
+ printIdentLike lbl;
+ Doc.text " as ";
+ printPattern pattern cmtTbl
+ ]
+ in
+ let optionalLabelSuffix = match (lbl, defaultExpr) with
+ | (Asttypes.Optional _, None) -> Doc.text "=?"
+ | _ -> Doc.nil
+ in
+ let doc = Doc.group (
+ Doc.concat [
+ uncurried;
+ attrs;
+ labelWithPattern;
+ defaultExprDoc;
+ optionalLabelSuffix;
+ ]
+ ) in
+ let cmtLoc = match defaultExpr with
+ | None ->
+ begin match pattern.ppat_attributes with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ ->
+ {loc with loc_end = pattern.ppat_loc.loc_end}
+ | _ -> pattern.ppat_loc
+ end
+ | Some expr ->
+ let startPos = match pattern.ppat_attributes with
+ | ({Location.txt = "ns.namedArgLoc"; loc}, _)::_ ->
+ loc.loc_start
+ | _ -> pattern.ppat_loc.loc_start
+ in {
+ pattern.ppat_loc with
+ loc_start = startPos;
+ loc_end = expr.pexp_loc.loc_end
+ }
+ in
+ printComments doc cmtTbl cmtLoc
+
+and printExpressionBlock ~braces expr cmtTbl =
+ let rec collectRows acc expr = match expr.Parsetree.pexp_desc with
+ | Parsetree.Pexp_letmodule (modName, modExpr, expr2) ->
+ let name =
+ let doc = Doc.text modName.txt in
+ printComments doc cmtTbl modName.loc
+ in
+ let letModuleDoc = Doc.concat [
+ Doc.text "module ";
+ name;
+ Doc.text " = ";
+ printModExpr modExpr cmtTbl;
+ ] in
+ let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in
+ collectRows ((loc, letModuleDoc)::acc) expr2
+ | Pexp_letexception (extensionConstructor, expr2) ->
+ let loc =
+ let loc = {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in
+ match getFirstLeadingComment cmtTbl loc with
+ | None -> loc
+ | Some comment ->
+ let cmtLoc = Comment.loc comment in
+ {cmtLoc with loc_end = loc.loc_end}
+ in
+ let letExceptionDoc = printExceptionDef extensionConstructor cmtTbl in
+ collectRows ((loc, letExceptionDoc)::acc) expr2
+ | Pexp_open (overrideFlag, longidentLoc, expr2) ->
+ let openDoc = Doc.concat [
+ Doc.text "open";
+ printOverrideFlag overrideFlag;
+ Doc.space;
+ printLongidentLocation longidentLoc cmtTbl;
+ ] in
+ let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in
+ collectRows ((loc, openDoc)::acc) expr2
+ | Pexp_sequence (expr1, expr2) ->
+ let exprDoc =
+ let doc = printExpression expr1 cmtTbl in
+ match Parens.expr expr1 with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr1 braces
+ | Nothing -> doc
+ in
+ let loc = expr1.pexp_loc in
+ collectRows ((loc, exprDoc)::acc) expr2
+ | Pexp_let (recFlag, valueBindings, expr2) ->
+ let loc =
+ let loc = match (valueBindings, List.rev valueBindings) with
+ | (vb::_, lastVb::_) -> {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end}
+ | _ -> Location.none
+ in
+ match getFirstLeadingComment cmtTbl loc with
+ | None -> loc
+ | Some comment ->
+ let cmtLoc = Comment.loc comment in
+ {cmtLoc with loc_end = loc.loc_end}
+ in
+ let recFlag = match recFlag with
+ | Asttypes.Nonrecursive -> Doc.nil
+ | Asttypes.Recursive -> Doc.text "rec "
+ in
+ let letDoc = printValueBindings ~recFlag valueBindings cmtTbl in
+ (* let () = {
+ * let () = foo()
+ * ()
+ * }
+ * We don't need to print the () on the last line of the block
+ *)
+ begin match expr2.pexp_desc with
+ | Pexp_construct ({txt = Longident.Lident "()"}, _) ->
+ List.rev ((loc, letDoc)::acc)
+ | _ ->
+ collectRows ((loc, letDoc)::acc) expr2
+ end
+ | _ ->
+ let exprDoc =
+ let doc = printExpression expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc
+ in
+ List.rev ((expr.pexp_loc, exprDoc)::acc)
+ in
+ let rows = collectRows [] expr in
+ let block =
+ printList
+ ~getLoc:fst
+ ~nodes:rows
+ ~print:(fun (_, doc) _ -> doc)
+ ~forceBreak:true
+ cmtTbl
+ in
+ Doc.breakableGroup ~forceBreak:true (
+ if braces then
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ block;
+ ]
+ );
+ Doc.line;
+ Doc.rbrace;
+ ]
+ else block
+ )
+
+(*
+ * // user types:
+ * let f = (a, b) => { a + b }
+ *
+ * // printer: everything is on one line
+ * let f = (a, b) => { a + b }
+ *
+ * // user types: over multiple lines
+ * let f = (a, b) => {
+ * a + b
+ * }
+ *
+ * // printer: over multiple lines
+ * let f = (a, b) => {
+ * a + b
+ * }
+ *)
+and printBraces doc expr bracesLoc =
+ let overMultipleLines =
+ let open Location in
+ bracesLoc.loc_end.pos_lnum > bracesLoc.loc_start.pos_lnum
+ in
+ match expr.Parsetree.pexp_desc with
+ | Pexp_letmodule _
+ | Pexp_letexception _
+ | Pexp_let _
+ | Pexp_open _
+ | Pexp_sequence _ ->
+ (* already has braces *)
+ doc
+ | _ ->
+ Doc.breakableGroup ~forceBreak:overMultipleLines (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ if Parens.bracedExpr expr then addParens doc else doc;
+ ]
+ );
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+
+and printOverrideFlag overrideFlag = match overrideFlag with
+ | Asttypes.Override -> Doc.text "!"
+ | Fresh -> Doc.nil
+
+and printDirectionFlag flag = match flag with
+ | Asttypes.Downto -> Doc.text " downto "
+ | Asttypes.Upto -> Doc.text " to "
+
+and printRecordRow (lbl, expr) cmtTbl =
+ let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in
+ let doc = Doc.group (Doc.concat [
+ printLidentPath lbl cmtTbl;
+ Doc.text ": ";
+ (let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc);
+ ]) in
+ printComments doc cmtTbl cmtLoc
+
+and printBsObjectRow (lbl, expr) cmtTbl =
+ let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in
+ let lblDoc =
+ let doc = Doc.concat [
+ Doc.text "\"";
+ printLongident lbl.txt;
+ Doc.text "\"";
+ ] in
+ printComments doc cmtTbl lbl.loc
+ in
+ let doc = Doc.concat [
+ lblDoc;
+ Doc.text ": ";
+ (let doc = printExpressionWithComments expr cmtTbl in
+ match Parens.expr expr with
+ | Parens.Parenthesized -> addParens doc
+ | Braced braces -> printBraces doc expr braces
+ | Nothing -> doc);
+ ] in
+ printComments doc cmtTbl cmtLoc
+
+(* The optional loc indicates whether we need to print the attributes in
+ * relation to some location. In practise this means the following:
+ * `@attr type t = string` -> on the same line, print on the same line
+ * `@attr
+ * type t = string` -> attr is on prev line, print the attributes
+ * with a line break between, we respect the users' original layout *)
+and printAttributes ?loc ?(inline=false) (attrs: Parsetree.attributes) cmtTbl =
+ match ParsetreeViewer.filterParsingAttrs attrs with
+ | [] -> Doc.nil
+ | attrs ->
+ let lineBreak = match loc with
+ | None -> Doc.line
+ | Some loc -> begin match List.rev attrs with
+ | ({loc = firstLoc}, _)::_ when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum ->
+ Doc.hardLine;
+ | _ -> Doc.line
+ end
+ in
+ Doc.concat [
+ Doc.group (Doc.join ~sep:Doc.line (List.map (fun attr -> printAttribute attr cmtTbl) attrs));
+ if inline then Doc.space else lineBreak;
+ ]
+
+and printPayload (payload : Parsetree.payload) cmtTbl =
+ match payload with
+ | PStr [] -> Doc.nil
+ | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] ->
+ let exprDoc = printExpressionWithComments expr cmtTbl in
+ let needsParens = match attrs with | [] -> false | _ -> true in
+ let shouldHug = ParsetreeViewer.isHuggableExpression expr in
+ if shouldHug then
+ Doc.concat [
+ Doc.lparen;
+ printAttributes attrs cmtTbl;
+ if needsParens then addParens exprDoc else exprDoc;
+ Doc.rparen;
+ ]
+ else
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ printAttributes attrs cmtTbl;
+ if needsParens then addParens exprDoc else exprDoc;
+ ]
+ );
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ | PStr [{pstr_desc = Pstr_value (_recFlag, _bindings)} as si] ->
+ addParens(printStructureItem si cmtTbl)
+ | PStr structure ->
+ addParens(printStructure structure cmtTbl)
+ | PTyp typ ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.text ":";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printTypExpr typ cmtTbl;
+ ];
+ );
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ | PPat (pat, optExpr) ->
+ let whenDoc = match optExpr with
+ | Some expr ->
+ Doc.concat [
+ Doc.line;
+ Doc.text "if ";
+ printExpressionWithComments expr cmtTbl;
+ ]
+ | None -> Doc.nil
+ in
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.text "? ";
+ printPattern pat cmtTbl;
+ whenDoc;
+ ]
+ );
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ | PSig signature ->
+ Doc.concat [
+ Doc.lparen;
+ Doc.text ":";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printSignature signature cmtTbl;
+ ];
+ );
+ Doc.softLine;
+ Doc.rparen;
+ ]
+
+and printAttribute ((id, payload) : Parsetree.attribute) cmtTbl =
+ Doc.group (
+ Doc.concat [
+ Doc.text "@";
+ Doc.text (convertBsExternalAttribute id.txt);
+ printPayload payload cmtTbl
+ ]
+ )
+
+and printModExpr modExpr cmtTbl =
+ let doc = match modExpr.pmod_desc with
+ | Pmod_ident longidentLoc ->
+ printLongidentLocation longidentLoc cmtTbl
+ | Pmod_structure [] ->
+ let shouldBreak =
+ modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum
+ in
+ Doc.breakableGroup ~forceBreak:shouldBreak (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ printCommentsInside cmtTbl modExpr.pmod_loc;
+ ];
+ );
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+ | Pmod_structure structure ->
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ printStructure structure cmtTbl;
+ ];
+ );
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+ | Pmod_unpack expr ->
+ let shouldHug = match expr.pexp_desc with
+ | Pexp_let _ -> true
+ | Pexp_constraint (
+ {pexp_desc = Pexp_let _ },
+ {ptyp_desc = Ptyp_package _packageType}
+ ) -> true
+ | _ -> false
+ in
+ let (expr, moduleConstraint) = match expr.pexp_desc with
+ | Pexp_constraint (
+ expr,
+ {ptyp_desc = Ptyp_package packageType; ptyp_loc}
+ ) ->
+ let packageDoc =
+ let doc = printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl in
+ printComments doc cmtTbl ptyp_loc
+ in
+ let typeDoc = Doc.group (Doc.concat [
+ Doc.text ":";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ packageDoc
+ ]
+ )
+ ]) in
+ (expr, typeDoc)
+ | _ -> (expr, Doc.nil)
+ in
+ let unpackDoc = Doc.group(Doc.concat [
+ printExpressionWithComments expr cmtTbl;
+ moduleConstraint;
+ ]) in
+ Doc.group (
+ Doc.concat [
+ Doc.text "unpack(";
+ if shouldHug then unpackDoc
+ else
+ Doc.concat [
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ unpackDoc;
+ ]
+ );
+ Doc.softLine;
+ ];
+ Doc.rparen;
+ ]
+ )
+ | Pmod_extension extension ->
+ printExtension ~atModuleLvl:false extension cmtTbl
+ | Pmod_apply _ ->
+ let (args, callExpr) = ParsetreeViewer.modExprApply modExpr in
+ let isUnitSugar = match args with
+ | [{pmod_desc = Pmod_structure []}] -> true
+ | _ -> false
+ in
+ let shouldHug = match args with
+ | [{pmod_desc = Pmod_structure _}] -> true
+ | _ -> false
+ in
+ Doc.group (
+ Doc.concat [
+ printModExpr callExpr cmtTbl;
+ if isUnitSugar then
+ printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl
+ else
+ Doc.concat [
+ Doc.lparen;
+ if shouldHug then
+ printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl
+ else
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun modArg -> printModApplyArg modArg cmtTbl) args
+ )
+ ]
+ );
+ if not shouldHug then
+ Doc.concat [
+ Doc.trailingComma;
+ Doc.softLine;
+ ]
+ else Doc.nil;
+ Doc.rparen;
+ ]
+ ]
+ )
+ | Pmod_constraint (modExpr, modType) ->
+ Doc.concat [
+ printModExpr modExpr cmtTbl;
+ Doc.text ": ";
+ printModType modType cmtTbl;
+ ]
+ | Pmod_functor _ ->
+ printModFunctor modExpr cmtTbl
+ in
+ printComments doc cmtTbl modExpr.pmod_loc
+
+and printModFunctor modExpr cmtTbl =
+ let (parameters, returnModExpr) = ParsetreeViewer.modExprFunctor modExpr in
+ (* let shouldInline = match returnModExpr.pmod_desc with *)
+ (* | Pmod_structure _ | Pmod_ident _ -> true *)
+ (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *)
+ (* | _ -> false *)
+ (* in *)
+ let (returnConstraint, returnModExpr) = match returnModExpr.pmod_desc with
+ | Pmod_constraint (modExpr, modType) ->
+ let constraintDoc =
+ let doc = printModType modType cmtTbl in
+ if Parens.modExprFunctorConstraint modType then addParens doc else doc
+ in
+ let modConstraint = Doc.concat [
+ Doc.text ": ";
+ constraintDoc;
+ ] in
+ (modConstraint, printModExpr modExpr cmtTbl)
+ | _ -> (Doc.nil, printModExpr returnModExpr cmtTbl)
+ in
+ let parametersDoc = match parameters with
+ | [(attrs, {txt = "*"}, None)] ->
+ Doc.group (
+ Doc.concat [
+ printAttributes attrs cmtTbl;
+ Doc.text "()"
+ ]
+ )
+ | [([], {txt = lbl}, None)] -> Doc.text lbl
+ | parameters ->
+ Doc.group (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun param -> printModFunctorParam param cmtTbl) parameters
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ in
+ Doc.group (
+ Doc.concat [
+ parametersDoc;
+ returnConstraint;
+ Doc.text " => ";
+ returnModExpr
+ ]
+ )
+
+and printModFunctorParam (attrs, lbl, optModType) cmtTbl =
+ let cmtLoc = match optModType with
+ | None -> lbl.Asttypes.loc
+ | Some modType -> {lbl.loc with loc_end =
+ modType.Parsetree.pmty_loc.loc_end
+ }
+ in
+ let attrs = printAttributes attrs cmtTbl in
+ let lblDoc =
+ let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in
+ printComments doc cmtTbl lbl.loc
+ in
+ let doc = Doc.group (
+ Doc.concat [
+ attrs;
+ lblDoc;
+ (match optModType with
+ | None -> Doc.nil
+ | Some modType ->
+ Doc.concat [
+ Doc.text ": ";
+ printModType modType cmtTbl
+ ]);
+ ]
+ ) in
+ printComments doc cmtTbl cmtLoc
+
+and printModApplyArg modExpr cmtTbl =
+ match modExpr.pmod_desc with
+ | Pmod_structure [] -> Doc.text "()"
+ | _ -> printModExpr modExpr cmtTbl
+
+
+and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl =
+ let kind = match constr.pext_kind with
+ | Pext_rebind longident -> Doc.indent (
+ Doc.concat [
+ Doc.text " =";
+ Doc.line;
+ printLongidentLocation longident cmtTbl;
+ ]
+ )
+ | Pext_decl (Pcstr_tuple [], None) -> Doc.nil
+ | Pext_decl (args, gadt) ->
+ let gadtDoc = match gadt with
+ | Some typ -> Doc.concat [
+ Doc.text ": ";
+ printTypExpr typ cmtTbl
+ ]
+ | None -> Doc.nil
+ in
+ Doc.concat [
+ printConstructorArguments ~indent:false args cmtTbl;
+ gadtDoc
+ ]
+ in
+ let name =
+ printComments
+ (Doc.text constr.pext_name.txt)
+ cmtTbl
+ constr.pext_name.loc
+ in
+ let doc = Doc.group (
+ Doc.concat [
+ printAttributes constr.pext_attributes cmtTbl;
+ Doc.text "exception ";
+ name;
+ kind
+ ]
+ ) in
+ printComments doc cmtTbl constr.pext_loc
+
+and printExtensionConstructor (constr : Parsetree.extension_constructor) cmtTbl i =
+ let attrs = printAttributes constr.pext_attributes cmtTbl in
+ let bar = if i > 0 then Doc.text "| "
+ else Doc.ifBreaks (Doc.text "| ") Doc.nil
+ in
+ let kind = match constr.pext_kind with
+ | Pext_rebind longident -> Doc.indent (
+ Doc.concat [
+ Doc.text " =";
+ Doc.line;
+ printLongidentLocation longident cmtTbl;
+ ]
+ )
+ | Pext_decl (Pcstr_tuple [], None) -> Doc.nil
+ | Pext_decl (args, gadt) ->
+ let gadtDoc = match gadt with
+ | Some typ -> Doc.concat [
+ Doc.text ": ";
+ printTypExpr typ cmtTbl;
+ ]
+ | None -> Doc.nil
+ in
+ Doc.concat [
+ printConstructorArguments ~indent:false args cmtTbl;
+ gadtDoc
+ ]
+ in
+ let name =
+ printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc
+ in
+ Doc.concat [
+ bar;
+ Doc.group (
+ Doc.concat [
+ attrs;
+ name;
+ kind;
+ ]
+ )
+ ]
+
+let printImplementation ~width (s: Parsetree.structure) ~comments =
+ let cmtTbl = CommentTable.make () in
+ CommentTable.walkStructure s cmtTbl comments;
+ (* CommentTable.log cmtTbl; *)
+ let doc = printStructure s cmtTbl in
+ (* Doc.debug doc; *)
+ Doc.toString ~width doc ^ "\n"
+
+let printInterface ~width (s: Parsetree.signature) ~comments =
+ let cmtTbl = CommentTable.make () in
+ CommentTable.walkSignature s cmtTbl comments;
+ Doc.toString ~width (printSignature s cmtTbl) ^ "\n"
diff --git a/jscomp/napkin/res_printer.mli b/jscomp/napkin/res_printer.mli
new file mode 100644
index 0000000000..bfd0cd4d1c
--- /dev/null
+++ b/jscomp/napkin/res_printer.mli
@@ -0,0 +1,20 @@
+val convertBsExternalAttribute : string -> string
+val convertBsExtension : string -> string
+
+val printTypeParams :
+ (Parsetree.core_type * Asttypes.variance) list -> Res_comments_table.t -> Res_doc.t
+
+val printLongident : Longident.t -> Res_doc.t
+
+val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t
+
+val addParens : Res_doc.t -> Res_doc.t
+
+val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t
+
+val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t [@@live]
+
+val printImplementation :
+ width:int -> Parsetree.structure -> comments:Res_comment.t list -> string
+val printInterface :
+ width:int -> Parsetree.signature -> comments:Res_comment.t list -> string
diff --git a/jscomp/napkin/res_reporting.ml b/jscomp/napkin/res_reporting.ml
new file mode 100644
index 0000000000..f5bd4fe7a1
--- /dev/null
+++ b/jscomp/napkin/res_reporting.ml
@@ -0,0 +1,12 @@
+module Token = Res_token
+module Grammar = Res_grammar
+
+type problem =
+ | Unexpected of Token.t [@live]
+ | Expected of {token: Token.t; pos: Lexing.position; context: Grammar.t option} [@live]
+ | Message of string [@live]
+ | Uident [@live]
+ | Lident [@live]
+ | Unbalanced of Token.t [@live]
+
+type parseError = Lexing.position * problem
diff --git a/jscomp/napkin/res_scanner.ml b/jscomp/napkin/res_scanner.ml
new file mode 100644
index 0000000000..f018051775
--- /dev/null
+++ b/jscomp/napkin/res_scanner.ml
@@ -0,0 +1,782 @@
+module Diagnostics = Res_diagnostics
+module Token = Res_token
+module Comment = Res_comment
+
+type mode = Jsx | Diamond
+
+(* We hide the implementation detail of the scanner reading character. Our char
+will also contain the special -1 value to indicate end-of-file. This isn't
+ideal; we should clean this up *)
+let hackyEOFChar = Char.unsafe_chr (-1)
+type charEncoding = Char.t
+
+type t = {
+ filename: string;
+ src: string;
+ mutable err:
+ startPos: Lexing.position
+ -> endPos: Lexing.position
+ -> Diagnostics.category
+ -> unit;
+ mutable ch: charEncoding; (* current character *)
+ mutable offset: int; (* character offset *)
+ mutable lineOffset: int; (* current line offset *)
+ mutable lnum: int; (* current line number *)
+ mutable mode: mode list;
+}
+
+let setDiamondMode scanner =
+ scanner.mode <- Diamond::scanner.mode
+
+let setJsxMode scanner =
+ scanner.mode <- Jsx::scanner.mode
+
+let popMode scanner mode =
+ match scanner.mode with
+ | m::ms when m = mode ->
+ scanner.mode <- ms
+ | _ -> ()
+
+let inDiamondMode scanner = match scanner.mode with
+ | Diamond::_ -> true
+ | _ -> false
+
+let inJsxMode scanner = match scanner.mode with
+ | Jsx::_ -> true
+ | _ -> false
+
+let position scanner = Lexing.{
+ pos_fname = scanner.filename;
+ (* line number *)
+ pos_lnum = scanner.lnum;
+ (* offset of the beginning of the line (number
+ of characters between the beginning of the scanner and the beginning
+ of the line) *)
+ pos_bol = scanner.lineOffset;
+ (* [pos_cnum] is the offset of the position (number of
+ characters between the beginning of the scanner and the position). *)
+ pos_cnum = scanner.offset;
+}
+
+(* Small debugging util
+❯ echo 'let msg = "hello"' | ./lib/rescript.exe
+let msg = "hello"
+^-^ let 0-3
+let msg = "hello"
+ ^-^ msg 4-7
+let msg = "hello"
+ ^ = 8-9
+let msg = "hello"
+ ^-----^ string "hello" 10-17
+let msg = "hello"
+ ^ eof 18-18
+let msg = "hello"
+*)
+let _printDebug ~startPos ~endPos scanner token =
+ let open Lexing in
+ print_string scanner.src;
+ print_string ((String.make [@doesNotRaise]) startPos.pos_cnum ' ');
+ print_char '^';
+ (match endPos.pos_cnum - startPos.pos_cnum with
+ | 0 ->
+ if token = Token.Eof then ()
+ else assert false
+ | 1 -> ()
+ | n -> (
+ print_string ((String.make [@doesNotRaise]) (n - 2) '-');
+ print_char '^';
+ ));
+ print_char ' ';
+ print_string (Res_token.toString token);
+ print_char ' ';
+ print_int startPos.pos_cnum;
+ print_char '-';
+ print_int endPos.pos_cnum;
+ print_endline ""
+[@@live]
+
+let next scanner =
+ let nextOffset = scanner.offset + 1 in
+ (match scanner.ch with
+ | '\n' ->
+ scanner.lineOffset <- nextOffset;
+ scanner.lnum <- scanner.lnum + 1;
+ (* What about CRLF (\r + \n) on windows?
+ * \r\n will always be terminated by a \n
+ * -> we can just bump the line count on \n *)
+ | _ -> ());
+ if nextOffset < String.length scanner.src then (
+ scanner.offset <- nextOffset;
+ scanner.ch <- String.unsafe_get scanner.src scanner.offset;
+ ) else (
+ scanner.offset <- String.length scanner.src;
+ scanner.ch <- hackyEOFChar
+ )
+
+let next2 scanner =
+ next scanner;
+ next scanner
+
+let next3 scanner =
+ next scanner;
+ next scanner;
+ next scanner
+
+let peek scanner =
+ if scanner.offset + 1 < String.length scanner.src then
+ String.unsafe_get scanner.src (scanner.offset + 1)
+ else
+ hackyEOFChar
+
+let peek2 scanner =
+ if scanner.offset + 2 < String.length scanner.src then
+ String.unsafe_get scanner.src (scanner.offset + 2)
+ else
+ hackyEOFChar
+
+let make ~filename src =
+ {
+ filename;
+ src = src;
+ err = (fun ~startPos:_ ~endPos:_ _ -> ());
+ ch = if src = "" then hackyEOFChar else String.unsafe_get src 0;
+ offset = 0;
+ lineOffset = 0;
+ lnum = 1;
+ mode = [];
+ }
+
+
+(* generic helpers *)
+
+let isWhitespace ch =
+ match ch with
+ | ' ' | '\t' | '\n' | '\r' -> true
+ | _ -> false
+
+let rec skipWhitespace scanner =
+ if isWhitespace scanner.ch then (
+ next scanner;
+ skipWhitespace scanner
+ )
+
+let digitValue ch =
+ match ch with
+ | '0'..'9' -> (Char.code ch) - 48
+ | 'a'..'f' ->
+ (Char.code ch) - (Char.code 'a') + 10
+ | 'A'..'F' ->
+ (Char.code ch) + 32 - (Char.code 'a') + 10
+ | _ -> 16 (* larger than any legal value *)
+
+let rec skipLowerCaseChars scanner =
+ match scanner.ch with
+ | 'a'..'z' -> next scanner; skipLowerCaseChars scanner
+ | _ -> ()
+
+
+(* scanning helpers *)
+
+let scanIdentifier scanner =
+ let startOff = scanner.offset in
+ let rec skipGoodChars scanner =
+ match scanner.ch with
+ | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' ->
+ next scanner;
+ skipGoodChars scanner
+ | _ -> ()
+ in
+ skipGoodChars scanner;
+ let str = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in
+ if '{' == scanner.ch && str = "list" then begin
+ next scanner;
+ (* TODO: this isn't great *)
+ Token.lookupKeyword "list{"
+ end
+ else Token.lookupKeyword str
+
+let scanDigits scanner ~base =
+ if base <= 10 then
+ let rec loop scanner =
+ match scanner.ch with
+ | '0'..'9' | '_' -> next scanner; loop scanner
+ | _ -> ()
+ in loop scanner
+ else
+ let rec loop scanner =
+ match scanner.ch with
+ (* hex *)
+ | '0'..'9' | 'a'..'f' | 'A'..'F' | '_' -> next scanner; loop scanner
+ | _ -> ()
+ in loop scanner
+
+(* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *)
+let scanNumber scanner =
+ let startOff = scanner.offset in
+
+ (* integer part *)
+ let base = match scanner.ch with
+ | '0' ->
+ (match peek scanner with
+ | 'x' | 'X' -> next2 scanner; 16
+ | 'o' | 'O' -> next2 scanner; 8
+ | 'b' | 'B' -> next2 scanner; 2
+ | _ -> next scanner; 8)
+ | _ -> 10
+ in
+ scanDigits scanner ~base;
+
+ (* *)
+ let isFloat = if '.' == scanner.ch then (
+ next scanner;
+ scanDigits scanner ~base;
+ true
+ ) else
+ false
+ in
+
+ (* exponent part *)
+ let isFloat =
+ match scanner.ch with
+ | 'e' | 'E' | 'p' | 'P' ->
+ (match peek scanner with
+ | '+' | '-' -> next2 scanner
+ | _ -> next scanner);
+ scanDigits scanner ~base;
+ true
+ | _ -> isFloat
+ in
+ let literal =
+ (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff)
+ in
+
+ (* suffix *)
+ let suffix =
+ match scanner.ch with
+ | 'n' ->
+ let msg =
+ "Unsupported number type (nativeint). Did you mean `"
+ ^ literal
+ ^ "`?"
+ in
+ let pos = position scanner in
+ scanner.err ~startPos:pos ~endPos:pos (Diagnostics.message msg);
+ next scanner;
+ Some 'n'
+ | 'g'..'z' | 'G'..'Z' as ch ->
+ next scanner;
+ Some ch
+ | _ ->
+ None
+ in
+ if isFloat then
+ Token.Float {f = literal; suffix}
+ else
+ Token.Int {i = literal; suffix}
+
+let scanExoticIdentifier scanner =
+ (* TODO: are we disregarding the current char...? Should be a quote *)
+ next scanner;
+ let buffer = Buffer.create 20 in
+ let startPos = position scanner in
+
+ let rec scan () =
+ match scanner.ch with
+ | '"' -> next scanner
+ | '\n' | '\r' ->
+ (* line break *)
+ let endPos = position scanner in
+ scanner.err ~startPos ~endPos (Diagnostics.message "A quoted identifier can't contain line breaks.");
+ next scanner
+ | ch when ch == hackyEOFChar ->
+ let endPos = position scanner in
+ scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?")
+ | ch ->
+ Buffer.add_char buffer ch;
+ next scanner;
+ scan ()
+ in
+ scan ();
+ (* TODO: do we really need to create a new buffer instead of substring once? *)
+ Token.Lident (Buffer.contents buffer)
+
+let scanStringEscapeSequence ~startPos scanner =
+ let scan ~n ~base ~max =
+ let rec loop n x =
+ if n == 0 then x
+ else
+ let d = digitValue scanner.ch in
+ if d >= base then
+ let pos = position scanner in
+ let msg =
+ if scanner.ch == hackyEOFChar then "unclosed escape sequence"
+ else "unknown escape sequence"
+ in
+ scanner.err ~startPos ~endPos:pos (Diagnostics.message msg);
+ -1
+ else
+ let () = next scanner in
+ loop (n - 1) (x * base + d)
+ in
+ let x = loop n 0 in
+ if x > max || 0xD800 <= x && x < 0xE000 then
+ let pos = position scanner in
+ let msg = "escape sequence is invalid unicode code point" in
+ scanner.err ~startPos ~endPos:pos (Diagnostics.message msg)
+ in
+ match scanner.ch with
+ (* \ already consumed *)
+ | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' ->
+ next scanner
+ | '0'..'9' ->
+ (* decimal *)
+ scan ~n:3 ~base:10 ~max:255
+ | 'o' ->
+ (* octal *)
+ next scanner;
+ scan ~n:3 ~base:8 ~max:255
+ | 'x' ->
+ (* hex *)
+ next scanner;
+ scan ~n:2 ~base:16 ~max:255
+ | 'u' ->
+ next scanner;
+ (match scanner.ch with
+ | '{' ->
+ (* unicode code point escape sequence: '\u{7A}', one or more hex digits *)
+ next scanner;
+ let x = ref 0 in
+ while match scanner.ch with | '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false do
+ x := (!x * 16) + (digitValue scanner.ch);
+ next scanner
+ done;
+ (* consume '}' in '\u{7A}' *)
+ (match scanner.ch with
+ | '}' -> next scanner
+ | _ -> ());
+ | _ ->
+ scan ~n:4 ~base:16 ~max:Res_utf8.max
+ )
+ | _ ->
+ (* unknown escape sequence
+ * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *)
+ (*
+ let pos = position scanner in
+ let msg =
+ if ch == -1 then "unclosed escape sequence"
+ else "unknown escape sequence"
+ in
+ scanner.err ~startPos ~endPos:pos (Diagnostics.message msg)
+ *)
+ ()
+
+let scanString scanner =
+ (* assumption: we've just matched a quote *)
+
+ let startPosWithQuote = position scanner in
+ next scanner;
+ let firstCharOffset = scanner.offset in
+
+ let rec scan () =
+ match scanner.ch with
+ | '"' ->
+ let lastCharOffset = scanner.offset in
+ next scanner;
+ (String.sub [@doesNotRaise]) scanner.src firstCharOffset (lastCharOffset - firstCharOffset)
+ | '\\' ->
+ let startPos = position scanner in
+ next scanner;
+ scanStringEscapeSequence ~startPos scanner;
+ scan ()
+ | ch when ch == hackyEOFChar ->
+ let endPos = position scanner in
+ scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString;
+ (String.sub [@doesNotRaise]) scanner.src firstCharOffset (scanner.offset - firstCharOffset)
+ | _ ->
+ next scanner;
+ scan ()
+ in
+ Token.String (scan ())
+
+let scanEscape scanner =
+ (* '\' consumed *)
+ let offset = scanner.offset - 1 in
+ let convertNumber scanner ~n ~base =
+ let x = ref 0 in
+ for _ = n downto 1 do
+ let d = digitValue scanner.ch in
+ x := (!x * base) + d;
+ next scanner
+ done;
+ let c = !x in
+ if Res_utf8.isValidCodePoint c then
+ Char.unsafe_chr c
+ else
+ Char.unsafe_chr Res_utf8.repl
+ in
+ let codepoint = match scanner.ch with
+ | '0'..'9' -> convertNumber scanner ~n:3 ~base:10
+ | 'b' -> next scanner; '\008'
+ | 'n' -> next scanner; '\010'
+ | 'r' -> next scanner; '\013'
+ | 't' -> next scanner; '\009'
+ | 'x' -> next scanner; convertNumber scanner ~n:2 ~base:16
+ | 'o' -> next scanner; convertNumber scanner ~n:3 ~base:8
+ | 'u' ->
+ next scanner;
+ begin match scanner.ch with
+ | '{' ->
+ (* unicode code point escape sequence: '\u{7A}', one or more hex digits *)
+ next scanner;
+ let x = ref 0 in
+ while match scanner.ch with | '0'..'9' | 'a'..'f' | 'A'..'F' -> true | _ -> false do
+ x := (!x * 16) + (digitValue scanner.ch);
+ next scanner
+ done;
+ (* consume '}' in '\u{7A}' *)
+ (match scanner.ch with
+ | '}' -> next scanner
+ | _ -> ());
+ let c = !x in
+ if Res_utf8.isValidCodePoint c then
+ Char.unsafe_chr c
+ else
+ Char.unsafe_chr Res_utf8.repl
+ | _ ->
+ (* unicode escape sequence: '\u007A', exactly 4 hex digits *)
+ convertNumber scanner ~n:4 ~base:16
+ end
+ | ch -> next scanner; ch
+ in
+ let contents = (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) in
+ next scanner; (* Consume \' *)
+ (* TODO: do we know it's \' ? *)
+ Token.Codepoint {c = codepoint; original = contents}
+
+let scanSingleLineComment scanner =
+ let startOff = scanner.offset in
+ let startPos = position scanner in
+ let rec skip scanner =
+ match scanner.ch with
+ | '\n' | '\r' -> ()
+ | ch when ch == hackyEOFChar -> ()
+ | _ ->
+ next scanner;
+ skip scanner
+ in
+ skip scanner;
+ let endPos = position scanner in
+ Token.Comment (
+ Comment.makeSingleLineComment
+ ~loc:(Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false})
+ ((String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff))
+ )
+
+let scanMultiLineComment scanner =
+ (* assumption: we're only ever using this helper in `scan` after detecting a comment *)
+ let contentStartOff = scanner.offset + 2 in
+ let startPos = position scanner in
+ let rec scan ~depth =
+ (* invariant: depth > 0 right after this match. See assumption *)
+ match scanner.ch, peek scanner with
+ | '/', '*' ->
+ next2 scanner;
+ scan ~depth:(depth + 1)
+ | '*', '/' ->
+ next2 scanner;
+ if depth > 1 then scan ~depth:(depth - 1)
+ | ch, _ when ch == hackyEOFChar ->
+ let endPos = position scanner in
+ scanner.err ~startPos ~endPos Diagnostics.unclosedComment
+ | _ ->
+ next scanner;
+ scan ~depth
+ in
+ scan ~depth:0;
+ Token.Comment (
+ Comment.makeMultiLineComment
+ ~loc:(Location.{loc_start = startPos; loc_end = (position scanner); loc_ghost = false})
+ ((String.sub [@doesNotRaise]) scanner.src contentStartOff (scanner.offset - 2 - contentStartOff))
+ )
+
+let scanTemplateLiteralToken scanner =
+ let startOff = scanner.offset in
+
+ (* if starting } here, consume it *)
+ if scanner.ch == '}' then next scanner;
+
+ let startPos = position scanner in
+
+ let rec scan () =
+ match scanner.ch with
+ | '`' ->
+ next scanner;
+ Token.TemplateTail(
+ (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 1 - startOff)
+ )
+ | '$' ->
+ (match peek scanner with
+ | '{' ->
+ next2 scanner;
+ let contents =
+ (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - 2 - startOff)
+ in
+ Token.TemplatePart contents
+ | _ ->
+ next scanner;
+ scan())
+ | '\\' ->
+ (match peek scanner with
+ | '`' | '\\' | '$'
+ | '\n' | '\r' ->
+ (* line break *)
+ next2 scanner;
+ scan ()
+ | _ ->
+ next scanner;
+ scan ())
+ | ch when ch = hackyEOFChar ->
+ let endPos = position scanner in
+ scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate;
+ Token.TemplateTail(
+ (String.sub [@doesNotRaise]) scanner.src startOff (max (scanner.offset - 1 - startOff) 0)
+ )
+ | _ ->
+ next scanner;
+ scan ()
+ in
+ let token = scan () in
+ let endPos = position scanner in
+ (startPos, endPos, token)
+
+let rec scan scanner =
+ skipWhitespace scanner;
+ let startPos = position scanner in
+
+ let token = match scanner.ch with
+ (* peeking 0 char *)
+ | 'A'..'Z' | 'a'..'z' -> scanIdentifier scanner
+ | '0'..'9' -> scanNumber scanner
+ | '`' -> next scanner; Token.Backtick
+ | '~' -> next scanner; Token.Tilde
+ | '?' -> next scanner; Token.Question
+ | ';' -> next scanner; Token.Semicolon
+ | '(' -> next scanner; Token.Lparen
+ | ')' -> next scanner; Token.Rparen
+ | '[' -> next scanner; Token.Lbracket
+ | ']' -> next scanner; Token.Rbracket
+ | '{' -> next scanner; Token.Lbrace
+ | '}' -> next scanner; Token.Rbrace
+ | ',' -> next scanner; Token.Comma
+ | '"' -> scanString scanner
+
+ (* peeking 1 char *)
+ | '_' ->
+ (match peek scanner with
+ | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' -> scanIdentifier scanner
+ | _ -> next scanner; Token.Underscore)
+ | '#' ->
+ (match peek scanner with
+ | '=' -> next2 scanner; Token.HashEqual
+ | _ -> next scanner; Token.Hash)
+ | '*' ->
+ (match peek scanner with
+ | '*' -> next2 scanner; Token.Exponentiation
+ | '.' -> next2 scanner; Token.AsteriskDot
+ | _ -> next scanner; Token.Asterisk)
+ | '@' ->
+ (match peek scanner with
+ | '@' -> next2 scanner; Token.AtAt
+ | _ -> next scanner; Token.At)
+ | '%' ->
+ (match peek scanner with
+ | '%' -> next2 scanner; Token.PercentPercent
+ | _ -> next scanner; Token.Percent)
+ | '|' ->
+ (match peek scanner with
+ | '|' -> next2 scanner; Token.Lor
+ | '>' -> next2 scanner; Token.BarGreater
+ | _ -> next scanner; Token.Bar)
+ | '&' ->
+ (match peek scanner with
+ | '&' -> next2 scanner; Token.Land
+ | _ -> next scanner; Token.Band)
+ | ':' ->
+ (match peek scanner with
+ | '=' -> next2 scanner; Token.ColonEqual
+ | '>' -> next2 scanner; Token.ColonGreaterThan
+ | _ -> next scanner; Token.Colon)
+ | '\\' -> next scanner; scanExoticIdentifier scanner
+ | '/' ->
+ (match peek scanner with
+ | '/' -> next2 scanner; scanSingleLineComment scanner
+ | '*' -> scanMultiLineComment scanner
+ | '.' -> next2 scanner; Token.ForwardslashDot
+ | _ -> next scanner; Token.Forwardslash)
+ | '-' ->
+ (match peek scanner with
+ | '.' -> next2 scanner; Token.MinusDot
+ | '>' -> next2 scanner; Token.MinusGreater
+ | _ -> next scanner; Token.Minus)
+ | '+' ->
+ (match peek scanner with
+ | '.' -> next2 scanner; Token.PlusDot
+ | '+' -> next2 scanner; Token.PlusPlus
+ | '=' -> next2 scanner; Token.PlusEqual
+ | _ -> next scanner; Token.Plus)
+ | '>' ->
+ (match peek scanner with
+ | '=' when not (inDiamondMode scanner) -> next2 scanner; Token.GreaterEqual
+ | _ -> next scanner; Token.GreaterThan)
+ | '<' when not (inJsxMode scanner) ->
+ (match peek scanner with
+ | '=' -> next2 scanner; Token.LessEqual
+ | _ -> next scanner; Token.LessThan)
+ (* special handling for JSX < *)
+ | '<' ->
+ (* Imagine the following: <
+ * < indicates the start of a new jsx-element, the parser expects
+ * the name of a new element after the <
+ * Example:
+ * This signals a closing element. To simulate the two-token lookahead,
+ * the next scanner; Token.LessThanSlash
+ | '=' -> next scanner; Token.LessEqual
+ | _ -> Token.LessThan)
+
+ (* peeking 2 chars *)
+ | '.' ->
+ (match peek scanner, peek2 scanner with
+ | '.', '.' -> next3 scanner; Token.DotDotDot
+ | '.', _ -> next2 scanner; Token.DotDot
+ | _ -> next scanner; Token.Dot)
+ | '\'' ->
+ (match peek scanner, peek2 scanner with
+ | '\\', '"' ->
+ (* careful with this one! We're next-ing _once_ (not twice),
+ then relying on matching on the quote *)
+ next scanner; SingleQuote
+ | '\\', _ -> next2 scanner; scanEscape scanner
+ | ch, '\'' ->
+ let offset = scanner.offset + 1 in
+ next3 scanner;
+ Token.Codepoint {c = ch; original = (String.sub [@doesNotRaise]) scanner.src offset 1}
+ | ch, _ ->
+ next scanner;
+ let offset = scanner.offset in
+ let (codepoint, length) = Res_utf8.decodeCodePoint scanner.offset scanner.src (String.length scanner.src) in
+ for _ = 0 to length - 1 do
+ next scanner
+ done;
+ if scanner.ch = '\'' then (
+ let contents = (String.sub [@doesNotRaise]) scanner.src offset length in
+ next scanner;
+ Token.Codepoint {c = Obj.magic codepoint; original = contents}
+ ) else (
+ scanner.ch <- ch;
+ scanner.offset <- offset;
+ SingleQuote
+ ))
+ | '!' ->
+ (match peek scanner, peek2 scanner with
+ | '=', '=' -> next3 scanner; Token.BangEqualEqual
+ | '=', _ -> next2 scanner; Token.BangEqual
+ | _ -> next scanner; Token.Bang)
+ | '=' ->
+ (match peek scanner, peek2 scanner with
+ | '=', '=' -> next3 scanner; Token.EqualEqualEqual
+ | '=', _ -> next2 scanner; Token.EqualEqual
+ | '>', _ -> next2 scanner; Token.EqualGreater
+ | _ -> next scanner; Token.Equal)
+
+ (* special cases *)
+ | ch when ch == hackyEOFChar -> next scanner; Token.Eof
+ | ch ->
+ (* if we arrive here, we're dealing with an unknown character,
+ * report the error and continue scanning… *)
+ next scanner;
+ let endPos = position scanner in
+ scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch);
+ let (_, _, token) = scan scanner in
+ token
+ in
+ let endPos = position scanner in
+ (* _printDebug ~startPos ~endPos scanner token; *)
+ (startPos, endPos, token)
+
+
+(* misc helpers used elsewhere *)
+
+(* Imagine:
<
+ * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and
+ * determines the correct token to disambiguate *)
+let reconsiderLessThan scanner =
+ (* < consumed *)
+ skipWhitespace scanner;
+ if scanner.ch == '/' then
+ let () = next scanner in
+ Token.LessThanSlash
+ else
+ Token.LessThan
+
+(* If an operator has whitespace around both sides, it's a binary operator *)
+(* TODO: this helper seems out of place *)
+let isBinaryOp src startCnum endCnum =
+ if startCnum == 0 then false
+ else begin
+ (* we're gonna put some assertions and invariant checks here because this is
+ used outside of the scanner's normal invariant assumptions *)
+ assert (endCnum >= 0);
+ assert (startCnum > 0 && startCnum < String.length src);
+ let leftOk = isWhitespace (String.unsafe_get src (startCnum - 1)) in
+ (* we need some stronger confidence that endCnum is ok *)
+ let rightOk = endCnum >= String.length src || isWhitespace (String.unsafe_get src endCnum) in
+ leftOk && rightOk
+ end
+
+(* Assume `{` consumed, advances the scanner towards the ends of Reason quoted strings. (for conversion)
+ * In {| foo bar |} the scanner will be advanced until after the `|}` *)
+let tryAdvanceQuotedString scanner =
+ let rec scanContents tag =
+ match scanner.ch with
+ | '|' ->
+ next scanner;
+ (match scanner.ch with
+ | 'a'..'z' ->
+ let startOff = scanner.offset in
+ skipLowerCaseChars scanner;
+ let suffix =
+ (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff)
+ in begin
+ if tag = suffix then (
+ if scanner.ch = '}' then
+ next scanner
+ else
+ scanContents tag
+ ) else
+ scanContents tag
+ end
+ | '}' -> next scanner
+ | _ -> scanContents tag)
+ | ch when ch == hackyEOFChar ->
+ (* TODO: why is this place checking EOF and not others? *)
+ ()
+ | _ ->
+ next scanner;
+ scanContents tag
+ in
+ match scanner.ch with
+ | 'a'..'z' ->
+ let startOff = scanner.offset in
+ skipLowerCaseChars scanner;
+ let tag = (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) in
+ if scanner.ch = '|' then scanContents tag
+ | '|' ->
+ scanContents ""
+ | _ -> ()
diff --git a/jscomp/napkin/res_scanner.mli b/jscomp/napkin/res_scanner.mli
new file mode 100644
index 0000000000..777d171e6d
--- /dev/null
+++ b/jscomp/napkin/res_scanner.mli
@@ -0,0 +1,35 @@
+type mode = Jsx | Diamond
+
+type charEncoding
+
+type t = {
+ filename: string;
+ src: string;
+ mutable err:
+ startPos: Lexing.position
+ -> endPos: Lexing.position
+ -> Res_diagnostics.category
+ -> unit;
+ mutable ch: charEncoding; (* current character *)
+ mutable offset: int; (* character offset *)
+ mutable lineOffset: int; (* current line offset *)
+ mutable lnum: int; (* current line number *)
+ mutable mode: mode list;
+}
+
+val make: filename:string -> string -> t
+
+(* TODO: make this a record *)
+val scan: t -> (Lexing.position * Lexing.position * Res_token.t)
+
+val isBinaryOp: string -> int -> int -> bool
+
+val setJsxMode: t -> unit
+val setDiamondMode: t -> unit
+val popMode: t -> mode -> unit
+
+val reconsiderLessThan: t -> Res_token.t
+
+val scanTemplateLiteralToken: t -> (Lexing.position * Lexing.position * Res_token.t)
+
+val tryAdvanceQuotedString: t -> unit
diff --git a/jscomp/napkin/res_token.ml b/jscomp/napkin/res_token.ml
new file mode 100644
index 0000000000..b901276ab2
--- /dev/null
+++ b/jscomp/napkin/res_token.ml
@@ -0,0 +1,213 @@
+module Comment = Res_comment
+
+type t =
+ | Open
+ | True | False
+ | Codepoint of {c: char; original: string}
+ | 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 | While | Switch
+ | When
+ | EqualGreater | MinusGreater
+ | External
+ | Typ
+ | Private
+ | Mutable
+ | Constraint
+ | Include
+ | Module
+ | Of
+ | 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
+ | 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"
+ | Codepoint {original} -> "codepoint '" ^ original ^ "'"
+ | String s -> "string \"" ^ s ^ "\""
+ | Lident str -> str
+ | Uident str -> 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"
+ | While -> "while"
+ | Switch -> "switch"
+ | When -> "when"
+ | EqualGreater -> "=>" | MinusGreater -> "->"
+ | External -> "external"
+ | Typ -> "type"
+ | Private -> "private"
+ | Constraint -> "constraint"
+ | Mutable -> "mutable"
+ | Include -> "include"
+ | Module -> "module"
+ | Of -> "of"
+ | 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"
+ | Import -> "import"
+ | Export -> "export"
+
+let keywordTable = function
+| "and" -> And
+| "as" -> As
+| "assert" -> Assert
+| "constraint" -> Constraint
+| "else" -> Else
+| "exception" -> Exception
+| "export" -> Export
+| "external" -> External
+| "false" -> False
+| "for" -> For
+| "if" -> If
+| "import" -> Import
+| "in" -> In
+| "include" -> Include
+| "lazy" -> Lazy
+| "let" -> Let
+| "list{" -> List
+| "module" -> Module
+| "mutable" -> Mutable
+| "of" -> Of
+| "open" -> Open
+| "private" -> Private
+| "rec" -> Rec
+| "switch" -> Switch
+| "true" -> True
+| "try" -> Try
+| "type" -> Typ
+| "when" -> When
+| "while" -> While
+| _ -> raise Not_found
+[@@raises Not_found]
+
+let isKeyword = function
+ | And | As | Assert | Constraint | Else | Exception | Export
+ | External | False | For | If | Import | In | Include | Land | Lazy
+ | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec
+ | Switch | True | Try | Typ | When | While -> true
+ | _ -> false
+
+let lookupKeyword str =
+ try keywordTable str with
+ | Not_found ->
+ match str.[0] [@doesNotRaise] with
+ | 'A'..'Z' -> Uident str
+ | _ -> Lident str
+
+let isKeywordTxt str =
+ try let _ = keywordTable str in true with
+ | Not_found -> false
+
+let catch = Lident "catch"
diff --git a/jscomp/napkin/res_utf8.ml b/jscomp/napkin/res_utf8.ml
new file mode 100644
index 0000000000..a8fd99ee05
--- /dev/null
+++ b/jscomp/napkin/res_utf8.ml
@@ -0,0 +1,141 @@
+(* https://tools.ietf.org/html/rfc3629#section-10 *)
+(* let bom = 0xFEFF *)
+
+let repl = 0xFFFD
+
+(* let min = 0x0000 *)
+let max = 0x10FFFF
+
+let surrogateMin = 0xD800
+let surrogateMax = 0xDFFF
+
+(*
+ * Char. number range | UTF-8 octet sequence
+ * (hexadecimal) | (binary)
+ * --------------------+---------------------------------------------
+ * 0000 0000-0000 007F | 0xxxxxxx
+ * 0000 0080-0000 07FF | 110xxxxx 10xxxxxx
+ * 0000 0800-0000 FFFF | 1110xxxx 10xxxxxx 10xxxxxx
+ * 0001 0000-0010 FFFF | 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
+ *)
+let h2 = 0b1100_0000
+let h3 = 0b1110_0000
+let h4 = 0b1111_0000
+
+let cont_mask = 0b0011_1111
+
+type category = {
+ low: int;
+ high: int;
+ size: int;
+}
+
+let locb = 0b1000_0000
+let hicb = 0b1011_1111
+
+let categoryTable = [|
+(* 0 *) {low = -1; high= -1; size= 1}; (* invalid *)
+(* 1 *) {low = 1; high= -1; size= 1}; (* ascii *)
+(* 2 *) {low = locb; high= hicb; size= 2};
+(* 3 *) {low = 0xA0; high= hicb; size= 3};
+(* 4 *) {low = locb; high= hicb; size= 3};
+(* 5 *) {low = locb; high= 0x9F; size= 3};
+(* 6 *) {low = 0x90; high= hicb; size= 4};
+(* 7 *) {low = locb; high= hicb; size= 4};
+(* 8 *) {low = locb; high= 0x8F; size= 4};
+
+|]
+
+let categories = [|
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+ 1; 1; 1; 1; 1; 1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1 ;1;
+
+ 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;
+ 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;
+ 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;
+ 0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;0; 0; 0; 0;
+ (* surrogate range U+D800 - U+DFFFF = 55296 - 917503 *)
+ 0; 0; 2; 2;2; 2; 2; 2;2; 2; 2; 2;2; 2; 2; 2;
+ 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2;
+ 3; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 4; 5; 4; 4;
+ 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0;
+|]
+
+let decodeCodePoint i s len =
+ if len < 1 then (repl, 1) else
+ let first = int_of_char (String.unsafe_get s i) in
+ if first < 128 then (first, 1) else
+ let index = Array.unsafe_get categories first in
+ if index = 0 then
+ (repl, 1)
+ else
+ let cat = Array.unsafe_get categoryTable index in
+ if len < i + cat.size then
+ (repl, 1)
+ else if cat.size == 2 then
+ let c1 = int_of_char (String.unsafe_get s (i + 1)) in
+ if c1 < cat.low || cat.high < c1 then
+ (repl, 1)
+ else
+ let i1 = c1 land 0b00111111 in
+ let i0 = (first land 0b00011111) lsl 6 in
+ let uc = i0 lor i1 in
+ (uc, 2)
+ else if cat.size == 3 then
+ let c1 = int_of_char (String.unsafe_get s (i + 1)) in
+ let c2 = int_of_char (String.unsafe_get s (i + 2)) in
+ if c1 < cat.low || cat.high < c1 || c2 < locb || hicb < c2 then (repl, 1)
+ else
+ let i0 = (first land 0b00001111) lsl 12 in
+ let i1 = (c1 land 0b00111111) lsl 6 in
+ let i2 = (c2 land 0b00111111) in
+ let uc = i0 lor i1 lor i2 in
+ (uc, 3)
+ else
+ let c1 = int_of_char (String.unsafe_get s (i +1)) in
+ let c2 = int_of_char (String.unsafe_get s (i +2)) in
+ let c3 = int_of_char (String.unsafe_get s (i +3)) in
+ if c1 < cat.low || cat.high < c1 ||
+ c2 < locb || hicb < c2 || c3 < locb || hicb < c3
+ then (repl, 1)
+ else
+ let i1 = (c1 land 0x3f) lsl 12 in
+ let i2 = (c2 land 0x3f) lsl 6 in
+ let i3 = (c3 land 0x3f) in
+ let i0 = (first land 0x07) lsl 18 in
+ let uc = i0 lor i3 lor i2 lor i1 in
+ (uc, 4)
+
+let encodeCodePoint c =
+ if c <= 127 then (
+ let bytes = (Bytes.create [@doesNotRaise]) 1 in
+ Bytes.unsafe_set bytes 0 (Char.unsafe_chr c);
+ Bytes.unsafe_to_string bytes
+ ) else if c <= 2047 then (
+ let bytes = (Bytes.create [@doesNotRaise]) 2 in
+ Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h2 lor (c lsr 6)));
+ Bytes.unsafe_set bytes 1 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask)));
+ Bytes.unsafe_to_string bytes
+ ) else if c <= 65535 then (
+ let bytes = (Bytes.create [@doesNotRaise]) 3 in
+ Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h3 lor (c lsr 12)));
+ Bytes.unsafe_set bytes 1 (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask)));
+ Bytes.unsafe_set bytes 2 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask)));
+ Bytes.unsafe_to_string bytes
+ ) else (* if c <= max then *) (
+ let bytes = (Bytes.create [@doesNotRaise]) 4 in
+ Bytes.unsafe_set bytes 0 (Char.unsafe_chr (h4 lor (c lsr 18)));
+ Bytes.unsafe_set bytes 1 (Char.unsafe_chr (0b1000_0000 lor ((c lsr 12) land cont_mask)));
+ Bytes.unsafe_set bytes 2 (Char.unsafe_chr (0b1000_0000 lor ((c lsr 6) land cont_mask)));
+ Bytes.unsafe_set bytes 3 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask)));
+ Bytes.unsafe_to_string bytes
+ )
+
+let isValidCodePoint c =
+ 0 <= c && c < surrogateMin || surrogateMax < c && c <= max
diff --git a/jscomp/napkin/res_utf8.mli b/jscomp/napkin/res_utf8.mli
new file mode 100644
index 0000000000..4b7462a4e1
--- /dev/null
+++ b/jscomp/napkin/res_utf8.mli
@@ -0,0 +1,9 @@
+val repl: int
+
+val max: int
+
+val decodeCodePoint: int -> string -> int -> int * int
+
+val encodeCodePoint: int -> string
+
+val isValidCodePoint: int -> bool