SuccessorML record punning syntax

README.md

@@ -111,4 +111,7 @@ that the `--preview-only` flag is also enabled.
 not top-level expressions (terminated by a semicolon) are allowed.
 
 `-allow-opt-bar [true|false]` (default `false`) controls whether or not
-SuccessorML optional bar syntax is allowed.
+SuccessorML optional bar syntax is allowed.
+
+`-allow-record-pun-exps [true|false]` (default `false`) controls whether or not
+SuccessorML record punning syntax is allowed.

src/ast/AstType.sml

@@ -232,6 +232,11 @@ struct
       }
 
 
+    datatype 'exp row_exp =
+      RecordRow of {lab: Token.t, eq: Token.t, exp: 'exp}
+    | RecordPun of {id: Token.t}
+
+
     datatype exp =
       Const of Token.t
 
@@ -241,7 +246,7 @@ struct
     (** { lab = pat, ..., lab = pat } *)
     | Record of
         { left: Token.t
-        , elems: {lab: Token.t, eq: Token.t, exp: exp} Seq.t
+        , elems: exp row_exp Seq.t
         , delims: Token.t Seq.t (** Gotta remember the commas too! *)
         , right: Token.t
         }

src/parse-mlb/ParseAllSMLFromMLB.sml

@@ -13,6 +13,7 @@ sig
     , skipBasis: bool
     , allowTopExp: bool
     , allowOptBar: bool
+    , allowRecordPun: bool
     }
     -> FilePath.t
     -> (FilePath.t * Parser.parser_output) Seq.t
@@ -68,8 +69,8 @@ struct
   fun printErr m = TextIO.output (TextIO.stdErr, m)
 
   (** when skipBasis = true, we ignore paths containing $(SML_LIB) *)
-  fun parse {skipBasis, pathmap, allowTopExp, allowOptBar} mlbPath :
-    (FilePath.t * Parser.parser_output) Seq.t =
+  fun parse {skipBasis, pathmap, allowTopExp, allowOptBar, allowRecordPun}
+    mlbPath : (FilePath.t * Parser.parser_output) Seq.t =
     let
       open MLBAst
 
@@ -121,8 +122,10 @@ struct
 
               val (infdict, ast) =
                 Parser.parseWithInfdict
-                  {allowTopExp = allowTopExp, allowOptBar = allowOptBar}
-                  (#fixities basis) src
+                  { allowTopExp = allowTopExp
+                  , allowOptBar = allowOptBar
+                  , allowRecordPun = allowRecordPun
+                  } (#fixities basis) src
             in
               ({fixities = infdict}, [(path, ast)])
             end

src/parse/ParseExpAndDec.sml

@@ -8,11 +8,11 @@ sig
   type ('a, 'b) parser = ('a, 'b) ParserCombinators.parser
   type tokens = Token.t Seq.t
 
-  val dec: {forceExactlyOne: bool, allowOptBar: bool}
+  val dec: {forceExactlyOne: bool, allowOptBar: bool, allowRecordPun: bool}
            -> tokens
            -> (int * InfixDict.t, Ast.Exp.dec) parser
 
-  val exp: {allowOptBar: bool}
+  val exp: {allowOptBar: bool, allowRecordPun: bool}
            -> tokens
            -> InfixDict.t
            -> ExpPatRestriction.t
@@ -132,7 +132,7 @@ struct
     *)
 
 
-  fun dec {forceExactlyOne, allowOptBar} toks (start, infdict) =
+  fun dec {forceExactlyOne, allowOptBar, allowRecordPun} toks (start, infdict) =
     let
       val numToks = Seq.length toks
       fun tok i = Seq.nth toks i
@@ -180,7 +180,8 @@ struct
         PC.zeroOrMoreWhile c p s
 
       fun consume_exp infdict restriction i =
-        exp {allowOptBar = allowOptBar} toks infdict restriction i
+        exp {allowOptBar = allowOptBar, allowRecordPun = allowRecordPun} toks
+          infdict restriction i
 
       fun consume_opvid infdict i =
         let
@@ -692,7 +693,7 @@ struct
   (* ======================================================================= *)
 
 
-  and exp {allowOptBar} toks infdict restriction start =
+  and exp {allowOptBar, allowRecordPun} toks infdict restriction start =
     let
       val numToks = Seq.length toks
       fun tok i = Seq.nth toks i
@@ -735,7 +736,11 @@ struct
 
 
       fun consume_dec xx =
-        dec {forceExactlyOne = false, allowOptBar = allowOptBar} toks xx
+        dec
+          { forceExactlyOne = false
+          , allowOptBar = allowOptBar
+          , allowRecordPun = allowRecordPun
+          } toks xx
 
 
       fun consume_exp infdict restriction i =
@@ -934,10 +939,32 @@ struct
           fun parseElem i =
             let
               val (i, lab) = parse_recordLabel i
-              val (i, eq) = parse_reserved Token.Equal i
-              val (i, exp) = consume_exp infdict Restriction.None i
             in
-              (i, {lab = lab, eq = eq, exp = exp})
+              if
+                isReserved Token.Comma at i
+                orelse isReserved Token.CloseCurlyBracket at i
+              then
+                if allowRecordPun then
+                  (i, Ast.Exp.RecordPun {id = lab})
+                else
+                  ParserUtils.error
+                    { pos = Token.getSource lab
+                    , what = "Incomplete row in record expression."
+                    , explain = SOME
+                        "In Standard ML, each element of a record expression must \
+                        \look like: `<label> = <expression>`. Note that SuccessorML \
+                        \allows for \"record punning\", where (for example) the syntax \
+                        \`{x, y, z = foo}` is shorthand for `{x = x, y = y, z = foo}`. \
+                        \To enable this feature, use the command-line argument \
+                        \'-allow-record-pun-exps true'."
+                    }
+              else
+                let
+                  val (i, eq) = parse_reserved Token.Equal i
+                  val (i, exp) = consume_exp infdict Restriction.None i
+                in
+                  (i, Ast.Exp.RecordRow {lab = lab, eq = eq, exp = exp})
+                end
             end
 
           val (i, {elems, delims}) =

src/parse/Parser.sml

@@ -12,11 +12,14 @@ sig
     Ast of Ast.t
   | JustComments of Token.t Seq.t
 
-  val parse: {allowTopExp: bool, allowOptBar: bool} -> Source.t -> parser_output
-  val parseWithInfdict: {allowTopExp: bool, allowOptBar: bool}
-                        -> InfixDict.t
-                        -> Source.t
-                        -> (InfixDict.t * parser_output)
+  val parse: {allowTopExp: bool, allowOptBar: bool, allowRecordPun: bool}
+             -> Source.t
+             -> parser_output
+  val parseWithInfdict:
+    {allowTopExp: bool, allowOptBar: bool, allowRecordPun: bool}
+    -> InfixDict.t
+    -> Source.t
+    -> (InfixDict.t * parser_output)
 end =
 struct
 
@@ -32,7 +35,7 @@ struct
   type ('state, 'result) parser = 'state -> ('state * 'result)
   type 'state peeker = 'state -> bool
 
-  fun parseWithInfdict {allowTopExp, allowOptBar} infdict src =
+  fun parseWithInfdict {allowTopExp, allowOptBar, allowRecordPun} infdict src =
     let
       (** This might raise Lexer.Error *)
       val allTokens = Lexer.tokens src
@@ -345,8 +348,10 @@ struct
           let
             val ((i, infdict), dec) =
               ParseExpAndDec.dec
-                {forceExactlyOne = true, allowOptBar = allowOptBar} toks
-                (i, infdict)
+                { forceExactlyOne = true
+                , allowOptBar = allowOptBar
+                , allowRecordPun = allowRecordPun
+                } toks (i, infdict)
           in
             ((i, infdict), Ast.Str.DecCore dec)
           end
@@ -557,8 +562,9 @@ struct
         then
           let
             val (i, exp) =
-              ParseExpAndDec.exp {allowOptBar = allowOptBar} toks infdict
-                ExpPatRestriction.None i
+              ParseExpAndDec.exp
+                {allowOptBar = allowOptBar, allowRecordPun = allowRecordPun}
+                toks infdict ExpPatRestriction.None i
             val (i, semicolon) = ParseSimple.reserved toks Token.Semicolon i
           in
             ((i, infdict), Ast.TopExp {exp = exp, semicolon = semicolon})
@@ -609,7 +615,7 @@ struct
     end
 
 
-  fun parse (allows as {allowTopExp, allowOptBar}) src =
+  fun parse (allows as {allowTopExp, allowOptBar, allowRecordPun}) src =
     let val (_, result) = parseWithInfdict allows InfixDict.initialTopLevel src
     in result
     end

src/prettier-print/PrettierExpAndDec.sml

@@ -128,6 +128,11 @@ struct
         Source.length (Token.getSource t) >= singleTokBignessThreshold
         orelse Token.spansMultipleLines t
 
+      fun recordRowLabel row =
+        case row of
+          RecordPun {id} => id
+        | RecordRow {lab, ...} => lab
+
       fun looksBig depth exp =
         depth >= 3
         orelse
@@ -178,12 +183,12 @@ struct
             Seq.length elems >= 4
             orelse
             Util.exists (0, Seq.length elems) (fn i =>
-              let val {lab, eq, exp} = Seq.nth elems i
-              in looksBig (depth + 1) exp
-              end)
+              case Seq.nth elems i of
+                RecordPun {id} => tokIsBig id
+              | RecordRow {lab, eq, exp} => looksBig (depth + 1) exp)
             orelse
             SeqBasis.foldl op+ 0 (0, Seq.length elems) (fn i =>
-              Source.length (Token.getSource (#lab (Seq.nth elems i))))
+              Source.length (Token.getSource (recordRowLabel (Seq.nth elems i))))
             >= singleTokBignessThreshold
 
         | _ => true
@@ -308,7 +313,7 @@ struct
 
       | Record {left, elems, delims, right} =>
           let
-            fun showRow tab {lab, eq, exp} =
+            fun showRecordRow tab {lab, eq, exp} =
               if not (isSplittableExp exp) then
                 token lab ++ token eq ++ (withNewChild showExp tab) exp
               else
@@ -330,6 +335,11 @@ struct
                           , active = var ec
                           })
                     end))
+
+            fun showRow tab row =
+              case row of
+                RecordPun {id} => token id
+              | RecordRow xxx => showRecordRow tab xxx
           in
             showSequence (fn _ => false) (withNewChild showRow) tab
               {openn = left, elems = elems, delims = delims, close = right}

src/pretty-print/PrettyExpAndDec.sml

@@ -313,8 +313,11 @@ struct
           sequence left delims right (Seq.map showExp elems)
       | Record {left, elems, delims, right} =>
           let
-            fun showRow {lab, eq, exp} =
-              (token lab ++ space ++ token eq) \\ showExp exp
+            fun showRow row =
+              case row of
+                RecordPun _ => recordPunFail ()
+              | RecordRow {lab, eq, exp} =>
+                  (token lab ++ space ++ token eq) \\ showExp exp
           in
             sequence left delims right (Seq.map showRow elems)
           end

src/pretty-print/PrettyUtil.sml

@@ -22,6 +22,13 @@ struct
       \deprecation. Please use `-engine prettier` instead, \
       \which supports optional bar syntax."
 
+  fun recordPunFail () =
+    raise Fail
+      "unsupported: SuccessorML record punning syntax. Note: you are \
+      \using `-engine pretty`, which is headed towards \
+      \deprecation. Please use `-engine prettier` instead, \
+      \which supports record punning."
+
   fun seqWithSpaces elems f =
     if Seq.length elems = 0 then
       empty

src/smlfmt.sml

@@ -45,6 +45,10 @@ val optionalArgDesc =
   \                             Valid options are: true, false\n\
   \                             (default 'false')\n\
   \\n\
+  \  [-allow-record-pun-exps B] Enable/disable SuccessorML record punning syntax.\n\
+  \                             Valid options are: true, false\n\
+  \                             (default 'false')\n\
+  \\n\
   \  [--help]                   print this message\n"
 
 
@@ -63,6 +67,7 @@ val inputfiles = CommandLineArgs.positional ()
 
 val allowTopExp = CommandLineArgs.parseBool "allow-top-level-exps" true
 val allowOptBar = CommandLineArgs.parseBool "allow-opt-bar" false
+val allowRecordPun = CommandLineArgs.parseBool "allow-record-pun-exps" false
 val doDebug = CommandLineArgs.parseFlag "debug-engine"
 val doForce = CommandLineArgs.parseFlag "force"
 val doHelp = CommandLineArgs.parseFlag "help"
@@ -208,7 +213,11 @@ fun doSML filepath =
     val fp = FilePath.fromUnixPath filepath
     val source = Source.loadFromFile fp
     val result =
-      Parser.parse {allowTopExp = allowTopExp, allowOptBar = allowOptBar} source
+      Parser.parse
+        { allowTopExp = allowTopExp
+        , allowOptBar = allowOptBar
+        , allowRecordPun = allowRecordPun
+        } source
       handle exn => handleLexOrParseError exn
   in
     doSMLAst (fp, result)
@@ -224,6 +233,7 @@ fun doMLB filepath =
         , pathmap = pathmap
         , allowTopExp = allowTopExp
         , allowOptBar = allowOptBar
+        , allowRecordPun = allowRecordPun
         } fp
       handle exn => handleLexOrParseError exn
   in