Explore surface syntax for records with optional fields.

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

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

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
 

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 ": ";

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 ->

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

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,13 +4668,15 @@ and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed =
         Doc.concat
           [
             printAttributes expr.pexp_attributes cmtTbl;
+            printOptionalLabel expr.pexp_attributes;
             printLidentPath lbl cmtTbl;
           ]
       | _ ->
         Doc.concat
           [
             printLidentPath lbl cmtTbl;
             Doc.text ": ";
+            printOptionalLabel expr.pexp_attributes;
             (let doc = printExpressionWithComments expr cmtTbl in
              match Parens.expr expr with
              | Parens.Parenthesized -> addParens doc

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}
+type opt0 = {x: int, ?y: string}
+type opt = {x: int, ?y: string}

tests/oprint/oprint.res

@@ -360,4 +360,6 @@ type call = CleanStart
 
 let f = (~a=1, ()) => 1
 
-type opt = {x:int, @optional y: option<string>}
+type opt0 = {x:int, @optional y: option<string>}
+
+type opt = {x:int, @ns.optional y: option<string>}

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
+  | { 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 ]}

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}

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}

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}