Merge pull request #70 from shwestrick/allow-or-pats

SuccessorML or-pattern syntax

README.md

@@ -114,4 +114,7 @@ not top-level expressions (terminated by a semicolon) are 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.
+SuccessorML record punning syntax is allowed.
+
+`-allow-or-pats [true|false]` (default `false`) controls whether or not
+SuccessorML or-pattern syntax is allowed.

src/ast/Ast.sml

@@ -109,6 +109,7 @@ struct
           (case opp of
              SOME t => t
            | NONE => id)
+      | Or {elems, ...} => leftMostToken (Seq.nth elems 0)
   end
 
   structure Exp =

src/ast/AstAllows.sml

@@ -6,15 +6,17 @@
 structure AstAllows:
 sig
   type t
-  val make: {topExp: bool, optBar: bool, recordPun: bool} -> t
+  val make: {topExp: bool, optBar: bool, recordPun: bool, orPat: bool} -> t
   val topExp: t -> bool
   val optBar: t -> bool
   val recordPun: t -> bool
+  val orPat: t -> bool
 end =
 struct
-  datatype t = T of {topExp: bool, optBar: bool, recordPun: bool}
+  datatype t = T of {topExp: bool, optBar: bool, recordPun: bool, orPat: bool}
   fun make x = T x
   fun topExp (T x) = #topExp x
   fun optBar (T x) = #optBar x
   fun recordPun (T x) = #recordPun x
+  fun orPat (T x) = #orPat x
 end

src/ast/AstType.sml

@@ -137,6 +137,10 @@ struct
         , pat: pat
         }
 
+    (** SuccessorML "or patterns":
+      * pat | pat | ... | pat *)
+    | Or of {elems: pat Seq.t, delims: Token.t Seq.t (* `|` between pats *)}
+
     type t = pat
   end
 

src/parse/ParseExpAndDec.sml

@@ -167,7 +167,7 @@ struct
       fun parse_tycon i = PS.tycon toks i
       fun parse_ty i = PT.ty toks i
       fun parse_pat infdict restriction i =
-        PP.pat toks infdict restriction i
+        PP.pat allows toks infdict restriction i
 
 
       fun parse_zeroOrMoreDelimitedByReserved x i =
@@ -446,7 +446,7 @@ struct
               fun parseBranch (*vid*) i =
                 let
                   val (i, fname_args) =
-                    ParseFunNameArgs.fname_args toks infdict i
+                    ParseFunNameArgs.fname_args allows toks infdict i
 
                   val (i, ty) =
                     if not (isReserved Token.Colon at i) then
@@ -721,7 +721,7 @@ struct
       fun parse_recordLabel i = PS.recordLabel toks i
       fun parse_ty i = PT.ty toks i
       fun parse_pat infdict restriction i =
-        PP.pat toks infdict restriction i
+        PP.pat allows toks infdict restriction i
 
 
       fun parse_zeroOrMoreDelimitedByReserved x i =

src/parse/ParseFunNameArgs.sml

@@ -8,7 +8,10 @@ sig
   type ('a, 'b) parser = ('a, 'b) ParserCombinators.parser
   type tokens = Token.t Seq.t
 
-  val fname_args: tokens -> InfixDict.t -> (int, Ast.Exp.fname_args) parser
+  val fname_args: AstAllows.t
+                  -> tokens
+                  -> InfixDict.t
+                  -> (int, Ast.Exp.fname_args) parser
 end =
 struct
 
@@ -23,7 +26,7 @@ struct
   type tokens = Token.t Seq.t
 
 
-  fun fname_args toks infdict i =
+  fun fname_args allows toks infdict i =
     let
       val numToks = Seq.length toks
       fun tok i = Seq.nth toks i
@@ -41,7 +44,8 @@ struct
           fun continue i =
             not (isReserved Token.Colon i orelse isReserved Token.Equal i)
         in
-          PC.zeroOrMoreWhile continue (PP.pat toks infdict Restriction.At) i
+          PC.zeroOrMoreWhile continue
+            (PP.pat allows toks infdict Restriction.At) i
         end
 
 
@@ -75,13 +79,13 @@ struct
       fun infixedFun larg id i =
         let
           (* val _ = print ("infixedFun\n") *)
-          val (i, rarg) = PP.pat toks infdict Restriction.At i
+          val (i, rarg) = PP.pat allows toks infdict Restriction.At i
         in
           (i, Ast.Exp.InfixedFun {larg = larg, id = id, rarg = rarg})
         end
 
 
-      val (i, firstPat) = PP.pat toks infdict Restriction.At i
+      val (i, firstPat) = PP.pat allows toks infdict Restriction.At i
 
       fun err () =
         ParserUtils.error

src/parse/ParsePat.sml

@@ -1,4 +1,4 @@
-(** Copyright (c) 2020-2021 Sam Westrick
+(** Copyright (c) 2020-2023 Sam Westrick
   *
   * See the file LICENSE for details.
   *)
@@ -8,7 +8,8 @@ sig
   type ('a, 'b) parser = ('a, 'b) ParserCombinators.parser
   type tokens = Token.t Seq.t
 
-  val pat: tokens
+  val pat: AstAllows.t
+           -> tokens
            -> InfixDict.t
            -> ExpPatRestriction.t
            -> (int, Ast.Pat.pat) parser
@@ -59,7 +60,7 @@ struct
     end
 
 
-  fun pat toks infdict restriction start =
+  fun pat allows toks infdict restriction start =
     let
       val numToks = Seq.length toks
       fun tok i = Seq.nth toks i
@@ -78,6 +79,21 @@ struct
       fun parse_ty i = PT.ty toks i
 
       fun consume_pat infdict restriction i =
+        if not (Restriction.anyOkay restriction andalso AstAllows.orPat allows) then
+          consume_onePat infdict restriction i
+        else
+          let
+            val (i, {elems, delims}) =
+              parse_oneOrMoreDelimitedByReserved
+                { parseElem = consume_onePat infdict restriction
+                , delim = Token.Bar
+                } i
+          in
+            if Seq.length elems = 1 then (i, Seq.nth elems 0)
+            else (i, Ast.Pat.Or {elems = elems, delims = delims})
+          end
+
+      and consume_onePat infdict restriction i =
         let
           val (i, pat) =
             if isReserved Token.Underscore i then
@@ -96,7 +112,11 @@ struct
               consume_patRecord infdict (tok i) (i + 1)
             else
               ParserUtils.tokError toks
-                {pos = i, what = "Parser bug!", explain = NONE}
+                { pos = i
+                , what =
+                    "Unexpected token. Expected to see beginning of pattern."
+                , explain = NONE
+                }
         in
           consume_afterPat infdict restriction pat i
         end
@@ -137,7 +157,6 @@ struct
               (true, consume_patCon infdict (Ast.Pat.unpackForConPat pat) i)
 
             else if
-
               isReserved Token.Colon i andalso Restriction.anyOkay restriction
             then
               (true, consume_patTyped infdict pat (tok i) (i + 1))
@@ -151,6 +170,21 @@ struct
                   (i + 1)
               )
 
+            else if
+              isReserved Token.Bar i andalso Restriction.anyOkay restriction
+              andalso not (AstAllows.orPat allows)
+            then
+              ParserUtils.tokError toks
+                { pos = i
+                , what = "Unexpected '|' after pattern."
+                , explain = SOME
+                    "This might be the beginning of an \"or-pattern\", written \
+                    \`<pat1> | <pat2> | ...`, which matches any one of multiple \
+                    \patterns. Or-patterns are disallowed in Standard ML, but \
+                    \allowed in SuccessorML. To enable or-patterns, use the \
+                    \command-line argument '-allow-or-pats true'."
+                }
+
             else
               (false, (i, pat))
         in
@@ -252,7 +286,7 @@ struct
         *)
       and consume_patAs infdict {opp, id, ty} ass i =
         let
-          val (i, pat) = consume_pat infdict Restriction.None i
+          val (i, pat) = consume_onePat infdict Restriction.None i
         in
           ( i
           , Ast.Pat.Layered {opp = opp, id = id, ty = ty, ass = ass, pat = pat}
@@ -264,7 +298,7 @@ struct
         *            ^
         *)
       and consume_patCon infdict {opp, id} i =
-        let val (i, atpat) = consume_pat infdict Restriction.At i
+        let val (i, atpat) = consume_onePat infdict Restriction.At i
         in (i, Ast.Pat.Con {opp = opp, id = id, atpat = atpat})
         end
 
@@ -282,7 +316,7 @@ struct
         *        ^
         *)
       and consume_patInfix infdict leftPat vid i =
-        let val (i, rightPat) = consume_pat infdict Restriction.Inf i
+        let val (i, rightPat) = consume_onePat infdict Restriction.Inf i
         in (i, makeInfixPat infdict (leftPat, vid, rightPat))
         end
 

src/prettier-print/PrettierPat.sml

@@ -116,5 +116,16 @@ struct
 
       | Infix {left, id, right} =>
           showPat tab left ++ token id ++ withNewChild showPat tab right
+
+      | Or {elems, delims} =>
+          newTab tab (fn tab =>
+            let
+              fun f (d, p) =
+                at tab (token d) ++ withNewChild showPat tab p
+
+              val front = at tab (showPat tab (Seq.nth elems 0))
+            in
+              Seq.iterate op++ front (Seq.zipWith f (delims, Seq.drop elems 1))
+            end)
     end
 end

src/pretty-print/PrettyPat.sml

@@ -73,6 +73,8 @@ struct
             ]
       | Infix {left, id, right} =>
           showPat left ++ space ++ token id ++ space ++ showPat right
+
+      | Or _ => recordPunFail ()
     end
 
 end

src/pretty-print/PrettyUtil.sml

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

src/smlfmt.sml

@@ -49,6 +49,10 @@ val optionalArgDesc =
   \                             Valid options are: true, false\n\
   \                             (default 'false')\n\
   \\n\
+  \  [-allow-or-pats B]         Enable/disable SuccessorML or-pattern syntax.\n\
+  \                             Valid options are: true, false\n\
+  \                             (default 'false')\n\
+  \\n\
   \  [--help]                   print this message\n"
 
 
@@ -68,16 +72,20 @@ 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 allowOrPat = CommandLineArgs.parseBool "allow-or-pats" false
 val doDebug = CommandLineArgs.parseFlag "debug-engine"
 val doForce = CommandLineArgs.parseFlag "force"
 val doHelp = CommandLineArgs.parseFlag "help"
 val preview = CommandLineArgs.parseFlag "preview"
 val previewOnly = CommandLineArgs.parseFlag "preview-only"
 val showPreview = preview orelse previewOnly
 
-val allows =
-  AstAllows.make
-    {topExp = allowTopExp, optBar = allowOptBar, recordPun = allowRecordPun}
+val allows = AstAllows.make
+  { topExp = allowTopExp
+  , optBar = allowOptBar
+  , recordPun = allowRecordPun
+  , orPat = allowOrPat
+  }
 
 val _ =
   if doHelp orelse List.null inputfiles then