diff --git a/compiler-libs-406/oprint.ml b/compiler-libs-406/oprint.ml index 26ff1bcd..1aa71f66 100644 --- a/compiler-libs-406/oprint.ml +++ b/compiler-libs-406/oprint.ml @@ -390,7 +390,7 @@ and print_typargs ppf = pp_close_box ppf (); pp_print_space ppf () and print_out_label ppf (name, mut, opt, arg) = - fprintf ppf "@[<2>%s%s%s :@ %a@];" (if opt then "@optional " else "") (if mut then "mutable " else "") name + fprintf ppf "@[<2>%s%s%s :@ %a@];" (if mut then "mutable " else "") name (if opt then "?" else "") print_out_type arg let out_type = ref print_out_type diff --git a/compiler-libs-406/printtyp.ml b/compiler-libs-406/printtyp.ml index 57283b40..65772c7b 100644 --- a/compiler-libs-406/printtyp.ml +++ b/compiler-libs-406/printtyp.ml @@ -926,7 +926,7 @@ and tree_of_constructor cd = (name, args, Some ret) and tree_of_label l = - let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "optional") in + let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "optional" || txt = "ns.optional") in let typ = match l.ld_type.desc with | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 | _ -> l.ld_type in diff --git a/src/res_core.ml b/src/res_core.ml index 08f9bc77..831fe435 100644 --- a/src/res_core.ml +++ b/src/res_core.ml @@ -161,6 +161,15 @@ let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr []) let ternaryAttr = (Location.mknoloc "ns.ternary", Parsetree.PStr []) let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr []) +let optionalAttr = (Location.mknoloc "ns.optional", Parsetree.PStr []) + +let makeExpressionOptional ~optional (e : Parsetree.expression) = + if optional then {e with pexp_attributes = optionalAttr :: e.pexp_attributes} + else e +let makePatternOptional ~optional (p : Parsetree.pattern) = + if optional then {p with ppat_attributes = optionalAttr :: p.ppat_attributes} + else p + let suppressFragileMatchWarningAttr = ( Location.mknoloc "warning", Parsetree.PStr @@ -1200,6 +1209,13 @@ and parseConstrainedPatternRegion p = | token when Grammar.isPatternStart token -> Some (parseConstrainedPattern p) | _ -> None +and parseOptionalLabel p = + match p.Parser.token with + | Question -> + Parser.next p; + true + | _ -> false + (* field ::= * | longident * | longident : pattern @@ -1216,7 +1232,9 @@ and parseRecordPatternRowField ~attrs p = match p.Parser.token with | Colon -> Parser.next p; - parsePattern p + let optional = parseOptionalLabel p in + let pat = parsePattern p in + makePatternOptional ~optional pat | _ -> Ast_helper.Pat.var ~loc:label.loc ~attrs (Location.mkloc (Longident.last label.txt) label.loc) @@ -1232,6 +1250,13 @@ and parseRecordPatternRow p = Some (true, PatField (parseRecordPatternRowField ~attrs p)) | Uident _ | Lident _ -> Some (false, PatField (parseRecordPatternRowField ~attrs p)) + | Question -> ( + Parser.next p; + match p.token with + | Uident _ | Lident _ -> + let lid, pat = parseRecordPatternRowField ~attrs p in + Some (false, PatField (lid, makePatternOptional ~optional:true pat)) + | _ -> None) | Underscore -> Parser.next p; Some (false, PatUnderscore) @@ -2742,6 +2767,10 @@ and parseBracedOrRecordExpr p = let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | Question -> + let expr = parseRecordExpr ~startPos [] p in + Parser.expect Rbrace p; + expr | Uident _ | Lident _ -> ( let startToken = p.token in let valueOrConstructor = parseValueOrConstructor p in @@ -2772,7 +2801,9 @@ and parseBracedOrRecordExpr p = expr | Colon -> ( Parser.next p; + let optional = parseOptionalLabel p in let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in match p.token with | Rbrace -> Parser.next p; @@ -2939,7 +2970,9 @@ and parseRecordExprRow p = match p.Parser.token with | Colon -> Parser.next p; + let optional = parseOptionalLabel p in let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in Some (field, fieldExpr) | _ -> let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in @@ -2949,6 +2982,20 @@ and parseRecordExprRow p = | _ -> value in Some (field, value)) + | Question -> ( + Parser.next p; + match p.Parser.token with + | Lident _ | Uident _ -> + let startToken = p.token in + let field = parseValuePath p in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value + in + Some (field, makeExpressionOptional ~optional:true value) + | _ -> None) | _ -> None and parseRecordExprWithStringKeys ~startPos firstRow p = @@ -4241,15 +4288,19 @@ and parseFieldDeclarationRegion p = | Lident _ -> let lident, loc = parseLident p in let name = Location.mkloc lident loc in + let optional = parseOptionalLabel p 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} [] + Ast_helper.Typ.constr ~loc:name.loc ~attrs + {name with txt = Lident name.txt} + [] in let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let attrs = if optional then optionalAttr :: attrs else attrs in Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) | _ -> None diff --git a/src/res_outcome_printer.ml b/src/res_outcome_printer.ml index 2e6c4268..2c544cec 100644 --- a/src/res_outcome_printer.ml +++ b/src/res_outcome_printer.ml @@ -526,7 +526,7 @@ and printRecordDeclRowDoc (name, mut, opt, arg) = Doc.group (Doc.concat [ - (if opt then Doc.text "@optional " else Doc.nil); + (if opt then Doc.text "?" else Doc.nil); (if mut then Doc.text "mutable " else Doc.nil); printIdentLike ~allowUident:false name; Doc.text ": "; diff --git a/src/res_parsetree_viewer.ml b/src/res_parsetree_viewer.ml index 6c335975..8049d6a9 100644 --- a/src/res_parsetree_viewer.ml +++ b/src/res_parsetree_viewer.ml @@ -169,7 +169,7 @@ let filterParsingAttrs attrs = | ( { Location.txt = ( "ns.ternary" | "ns.braces" | "res.template" | "bs" | "ns.iflet" - | "ns.namedArgLoc" ); + | "ns.namedArgLoc" | "ns.optional" ); }, _ ) -> false @@ -304,6 +304,12 @@ let isIfLetExpr expr = true | _ -> false +let rec hasOptionalAttribute attrs = + match attrs with + | [] -> false + | ({Location.txt = "ns.optional"}, _) :: _ -> true + | _ :: attrs -> hasOptionalAttribute attrs + let hasAttributes attrs = List.exists (fun attr -> diff --git a/src/res_parsetree_viewer.mli b/src/res_parsetree_viewer.mli index 3fe3e1ee..e492010b 100644 --- a/src/res_parsetree_viewer.mli +++ b/src/res_parsetree_viewer.mli @@ -83,6 +83,7 @@ val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes val isJsxExpression : Parsetree.expression -> bool val hasJsxAttribute : Parsetree.attributes -> bool +val hasOptionalAttribute : Parsetree.attributes -> bool val shouldIndentBinaryExpr : Parsetree.expression -> bool val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool diff --git a/src/res_printer.ml b/src/res_printer.ml index 444ea339..02359977 100644 --- a/src/res_printer.ml +++ b/src/res_printer.ml @@ -523,6 +523,10 @@ let printConstant ?(templateLiteral = false) c = in Doc.text ("'" ^ str ^ "'") +let printOptionalLabel attrs = + if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" + else Doc.nil + let rec printStructure (s : Parsetree.structure) t = match s with | [] -> printCommentsInside t Location.none @@ -1426,10 +1430,16 @@ and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = let doc = printIdentLike ld.pld_name.txt in printComments doc cmtTbl ld.pld_name.loc in + let optional = printOptionalLabel ld.pld_attributes in Doc.group (Doc.concat [ - attrs; mutableFlag; name; Doc.text ": "; printTypExpr ld.pld_type cmtTbl; + attrs; + mutableFlag; + name; + optional; + Doc.text ": "; + printTypExpr ld.pld_type cmtTbl; ]) and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = @@ -2345,14 +2355,21 @@ and printPatternRecordRow row cmtTbl = {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) when ident = txt -> Doc.concat - [printAttributes ppat_attributes cmtTbl; printLidentPath longident cmtTbl] + [ + printOptionalLabel ppat_attributes; + printAttributes ppat_attributes cmtTbl; + 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 + let doc = + if Parens.patternRecordRowRhs pattern then addParens doc else doc + in + Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] in let doc = Doc.group @@ -4651,6 +4668,7 @@ and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = Doc.concat [ printAttributes expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; printLidentPath lbl cmtTbl; ] | _ -> @@ -4658,6 +4676,7 @@ and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = [ printLidentPath lbl cmtTbl; Doc.text ": "; + printOptionalLabel expr.pexp_attributes; (let doc = printExpressionWithComments expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc diff --git a/tests/oprint/expected/oprint.resi.txt b/tests/oprint/expected/oprint.resi.txt index fc46b88c..f53406da 100644 --- a/tests/oprint/expected/oprint.resi.txt +++ b/tests/oprint/expected/oprint.resi.txt @@ -486,4 +486,5 @@ type emptyObject = {.} let f: (~x: 'a=?, ~y: 'b) => option<'a> type call = CleanStart let f: (~a: int=?, unit) => int -type opt = {x: int, @optional y: string} \ No newline at end of file +type opt0 = {x: int, ?y: string} +type opt = {x: int, ?y: string} \ No newline at end of file diff --git a/tests/oprint/oprint.res b/tests/oprint/oprint.res index 856e371c..ee4d4cf2 100644 --- a/tests/oprint/oprint.res +++ b/tests/oprint/oprint.res @@ -360,4 +360,6 @@ type call = CleanStart let f = (~a=1, ()) => 1 -type opt = {x:int, @optional y: option} \ No newline at end of file +type opt0 = {x:int, @optional y: option} + +type opt = {x:int, @ns.optional y: option} \ No newline at end of file diff --git a/tests/parsing/grammar/expressions/expected/record.res.txt b/tests/parsing/grammar/expressions/expected/record.res.txt index 2088b88a..6e4fc91f 100644 --- a/tests/parsing/grammar/expressions/expected/record.res.txt +++ b/tests/parsing/grammar/expressions/expected/record.res.txt @@ -14,16 +14,27 @@ let r = { (make () : myRecord) with foo = bar } let r = { (make () : myRecord) with foo = bar } let r = { - x = ((None)[@optional ]); - y = ((None)[@optional ]); + x = ((None)[@ns.optional ]); + y = ((None)[@ns.optional ]); z = (((None : tt))[@optional ]) } let z name = { name = ((name)[@optional ]); x = 3 } -let z name = { name = ((name)[@optional ]); x = 3 } +let z name = { name = ((name)[@ns.optional ]); x = 3 } let z name = { name; x = ((x)[@optional ]) } +let zz name = { name; x = ((x)[@ns.optional ]) } let _ = match z with | { x = ((None)[@optional ]); y = ((None)[@optional ]); z = (((None : tt))[@optional ]) } -> 11 | { name = ((name)[@optional ]); x = 3 } -> 42 - | { name = ((name)[@optional ]); x = 3 } -> 4242 \ No newline at end of file + | { name = ((name)[@optional ]); x = 3 } -> 4242 + | { x = ((None)[@ns.optional ]); y = ((None)[@ns.optional ]); + z = (((None : tt))[@ns.optional ]) } -> 11 + | { name = ((name)[@ns.optional ]); x = 3 } -> 42 + | { name = ((name)[@ns.optional ]); x = 3 } -> 4242 +type nonrec tt = { + x: int ; + y: string [@ns.opttinal ]} +type nonrec ttt = { + x: int ; + y: string [@ns.optional ]} \ No newline at end of file diff --git a/tests/parsing/grammar/expressions/record.res b/tests/parsing/grammar/expressions/record.res index c8653e04..2f32f489 100644 --- a/tests/parsing/grammar/expressions/record.res +++ b/tests/parsing/grammar/expressions/record.res @@ -24,16 +24,25 @@ let r = {...expr, pexp_attributes: [],} // trailing comma let r = {...make() : myRecord, foo: bar} let r = {...(make() : myRecord), foo: bar} // parens optional -let r = {x: @optional None, y: @optional None, z: @optional (None:tt)} +let r = {x: ? None, y: ?None, z: @optional (None:tt)} let z = name => { name : @optional name, x: 3} -let z = name => { @optional name, x: 3} +let z = name => { ? name, x: 3} let z = name => { name, @optional x } +let zz = name => { name, ? x } + let _ = switch z { | {x: @optional None, y: @optional None, z: @optional (None:tt)} => 11 | {name: @optional name, x: 3} => 42 | {@optional name, x: 3} => 4242 + | {x: ? None, y: ? None, z: ? (None:tt)} => 11 + | {name: ? name, x: 3} => 42 + | {? name, x: 3} => 4242 } + +type tt = {x:int, @ns.opttinal y : string} + +type ttt = {x:int, y?: string} diff --git a/tests/printer/expr/expected/record.res.txt b/tests/printer/expr/expected/record.res.txt index f07c3b18..b792483a 100644 --- a/tests/printer/expr/expected/record.res.txt +++ b/tests/printer/expr/expected/record.res.txt @@ -74,16 +74,25 @@ let r = { } let r = {a /* a */, b /* b */} -let r = {x: @optional None, y: @optional None, z: (@optional None: tt)} +let r = {x: ?None, y: ?None, z: (@optional None: tt)} let z = name => {@optional name, x: 3} -let z = name => {@optional name, x: 3} +let z = name => {?name, x: 3} let z = name => {name, @optional x} +let zz = name => {name, ?x} + let _ = switch z { | {x: @optional None, y: @optional None, z: (@optional None: tt)} => 11 | {@optional name, x: 3} => 42 | {name: @optional dd, x: 3} => 42 +| {x: ?None, y: ?None, z: ?(None: tt)} => 11 +| {?name, x: 3} => 42 +| {?name, x: 3} => 4242 } + +type tt = {x: int, y?: string} + +type ttt = {x: int, y?: string} diff --git a/tests/printer/expr/record.res b/tests/printer/expr/record.res index fb6abd40..460bdd4e 100644 --- a/tests/printer/expr/record.res +++ b/tests/printer/expr/record.res @@ -64,16 +64,25 @@ let r = { } let r = {a /* a */, b /* b */} -let r = {x: @optional None, y: @optional None, z: @optional (None:tt)} +let r = {x: ? None, y: ?None, z: @optional (None:tt)} let z = name => { name : @optional name, x: 3} -let z = name => { @optional name, x: 3} +let z = name => { ? name, x: 3} let z = name => { name, @optional x } +let zz = name => { name, ? x } + let _ = switch z { | {x: @optional None, y: @optional None, z: @optional (None:tt)} => 11 | {name: @optional name, x: 3} => 42 | {name: @optional dd, x: 3} => 42 + | {x: ? None, y: ? None, z: ? (None:tt)} => 11 + | {name: ? name, x: 3} => 42 + | {? name, x: 3} => 4242 } + +type tt = {x:int, @ns.optional y: string} + +type ttt = {x:int, y?: string}