Monadic bind supports patterns

8 files changed, 121 insertions, 57 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 2a65c906..db4994a5 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -1442,6 +1442,8 @@ $$\begin{array}{l}
 
 The Ur/Web compiler provides syntactic sugar for monads, similar to Haskell's \cd{do} notation.  An expression $x \leftarrow e_1; e_2$ is desugared to $\mt{bind} \; e_1 \; (\lambda x \Rightarrow e_2)$, and an expression $e_1; e_2$ is desugared to $\mt{bind} \; e_1 \; (\lambda () \Rightarrow e_2)$.  Note a difference from Haskell: as the $e_1; e_2$ case desugaring involves a function with $()$ as its formal argument, the type of $e_1$ must be of the form $m \; \{\}$, rather than some arbitrary $m \; t$.
 
+The syntactic sugar also allows $p \leftarrow e_1; e_2$ for $p$ a pattern.  The pattern should be guaranteed to match any value of the corresponding type, or there will be a compile-time error.
+
 \subsection{Transactions}
 
 Ur is a pure language; we use Haskell's trick to support controlled side effects.  The standard library defines a monad $\mt{transaction}$, meant to stand for actions that may be undone cleanly.  By design, no other kinds of actions are supported.
diff --git a/src/elab_err.sig b/src/elab_err.sig
index b5e3d64d..acf137df 100644
--- a/src/elab_err.sig
+++ b/src/elab_err.sig
@@ -81,6 +81,7 @@ signature ELAB_ERR = sig
            | Unresolvable of ErrorMsg.span * Elab.con
            | OutOfContext of ErrorMsg.span * (Elab.exp * Elab.con) option
            | IllegalRec of string * Elab.exp
+           | IllegalFlex of Source.exp
 
     val expError : ElabEnv.env -> exp_error -> unit
 
diff --git a/src/elab_err.sml b/src/elab_err.sml
index 4754d4ce..33daa118 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -180,6 +180,7 @@ datatype exp_error =
      | Unresolvable of ErrorMsg.span * con
      | OutOfContext of ErrorMsg.span * (exp * con) option
      | IllegalRec of string * exp
+     | IllegalFlex of Source.exp
 
 val simplExp = U.Exp.mapB {kind = fn _ => fn k => k,
                            con = fn env => fn c => #1 (ElabOps.reduceCon env (c, ErrorMsg.dummySpan)),
@@ -251,6 +252,9 @@ fun expError env err =
         (ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)";
          eprefaces' [("Variable", PD.string x),
                      ("Expression", p_exp env e)])
+      | IllegalFlex e =>
+        (ErrorMsg.errorAt (#2 e) "Flex record syntax (\"...\") only allowed in patterns";
+         eprefaces' [("Expression", SourcePrint.p_exp e)])
 
 
 datatype decl_error =
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 5dd86f18..97ac610b 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2183,8 +2183,13 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                 (e', (#1 (chaseUnifs t'), loc), enD gs2 @ gs1)
             end
 
-          | L.ERecord xes =>
+          | L.ERecord (xes, flex) =>
             let
+                val () = if flex then
+                             expError env (IllegalFlex eAll)
+                         else
+                             ()
+
                 val (xes', gs) = ListUtil.foldlMap (fn ((x, e), gs) =>
                                                        let
                                                            val (x', xk, gs1) = elabCon (env, denv) x
diff --git a/src/source.sml b/src/source.sml
index 639ea716..eea7ad4c 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -125,7 +125,7 @@ and exp' =
 
   | EKAbs of string * exp
 
-  | ERecord of (con * exp) list
+  | ERecord of (con * exp) list * bool
   | EField of exp * con
   | EConcat of exp * exp
   | ECut of exp * con
diff --git a/src/source_print.sml b/src/source_print.sml
index ce095542..fdacfe6c 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -277,14 +277,20 @@ fun p_exp' par (e, _) =
                                             space,
                                             string "!"])
 
-      | ERecord xes => box [string "{",
-                            p_list (fn (x, e) =>
-                                       box [p_name x,
-                                            space,
-                                            string "=",
-                                            space,
-                                            p_exp e]) xes,
-                            string "}"]
+      | ERecord (xes, flex) => box [string "{",
+                                    p_list (fn (x, e) =>
+                                               box [p_name x,
+                                                    space,
+                                                    string "=",
+                                                    space,
+                                                    p_exp e]) xes,
+                                    if flex then
+                                        box [string ",",
+                                             space,
+                                             string "..."]
+                                    else
+                                        box [],
+                                    string "}"]
       | EField (e, c) => box [p_exp' true e,
                               string ".",
                               p_con' true c]
diff --git a/src/urweb.grm b/src/urweb.grm
index bb195cda..7aec9492 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -322,6 +322,39 @@ fun applyWindow loc e window =
         (EApp (e', ob), loc)
     end
 
+fun patternOut (e : exp) =
+    case #1 e of
+        EWild => (PWild, #2 e)
+      | EVar ([], x, Infer) =>
+        if Char.isUpper (String.sub (x, 0)) then
+            (PCon ([], x, NONE), #2 e)
+        else
+            (PVar x, #2 e)
+      | EVar (xs, x, Infer) =>
+        if Char.isUpper (String.sub (x, 0)) then
+            (PCon (xs, x, NONE), #2 e)
+        else
+            (ErrorMsg.errorAt (#2 e) "Badly capitalized constructor name in pattern";
+             (PWild, #2 e))
+      | EPrim p => (PPrim p, #2 e)
+      | EApp ((EVar (xs, x, Infer), _), e') =>
+        (PCon (xs, x, SOME (patternOut e')), #2 e)
+      | ERecord (xes, flex) =>
+        (PRecord (map (fn (x, e') =>
+                          let
+                              val x =
+                                  case #1 x of
+                                      CName x => x
+                                    | _ => (ErrorMsg.errorAt (#2 e) "Field name not constant in pattern";
+                                            "")
+                          in
+                              (x, patternOut e')
+                          end) xes, flex), #2 e)
+      | EAnnot (e', t) =>
+        (PAnnot (patternOut e', t), #2 e)
+      | _ => (ErrorMsg.errorAt (#2 e) "This is an expression but not a pattern.";
+              (PWild, #2 e))
+
 %%
 %header (functor UrwebLrValsFn(structure Token : TOKEN))
 
@@ -428,13 +461,13 @@ fun applyWindow loc e window =
  | eapps of exp
  | eterm of exp
  | etuple of exp list
- | rexp of (con * exp) list
+ | rexp of (con * exp) list * bool
  | xml of exp
  | xmlOne of exp
  | xmlOpt of exp
  | tag of (string * exp) * exp option * exp option * exp
  | tagHead of string * exp
- | bind of string * con option * exp
+ | bind of pat * con option * exp
  | edecl of edecl
  | edecls of edecl list
 
@@ -730,10 +763,10 @@ cst    : UNIQUE tnames                  (let
                                              val e = (EApp (e, mat), loc)
                                              val e = (EApp (e, texp), loc)
                                          in
-                                             (EApp (e, (ERecord [((CName "OnDelete", loc),
-                                                                  findMode Delete),
-                                                                 ((CName "OnUpdate", loc),
-                                                                  findMode Update)], loc)), loc)
+                                             (EApp (e, (ERecord ([((CName "OnDelete", loc),
+                                                                   findMode Delete),
+                                                                  ((CName "OnUpdate", loc),
+                                                                   findMode Update)], false), loc)), loc)
                                          end)
 
        | LBRACE eexp RBRACE             (eexp)
@@ -779,7 +812,7 @@ pk     : LBRACE LBRACE eexp RBRACE RBRACE (eexp)
                                              val witness = map (fn (c, _) =>
                                                                    (c, (EWild, loc)))
                                                            (#1 tnames :: #2 tnames)
-                                             val witness = (ERecord witness, loc)
+                                             val witness = (ERecord (witness, false), loc)
                                          in
                                              (EApp (e, witness), loc)
                                          end)
@@ -1136,11 +1169,17 @@ eexp   : eapps                          (case #1 eapps of
                                          end)
        | bind SEMI eexp                 (let
                                              val loc = s (bindleft, eexpright)
-                                             val (v, to, e1) = bind
+                                             val (p, to, e1) = bind
                                              val e = (EVar (["Basis"], "bind", Infer), loc)
                                              val e = (EApp (e, e1), loc)
+
+                                             val f = case #1 p of
+                                                         PVar v => (EAbs (v, to, eexp), loc)
+                                                       | _ => (EAbs ("$x", to,
+                                                                     (ECase ((EVar ([], "$x", Infer), loc),
+                                                                             [(p, eexp)]), loc)), loc)
                                          in
-                                             (EApp (e, (EAbs (v, to, eexp), loc)), loc)
+                                             (EApp (e, f), loc)
                                          end)
        | eexp EQ eexp                   (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right)))
        | eexp NE eexp                   (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right)))
@@ -1181,17 +1220,17 @@ eexp   : eapps                          (case #1 eapps of
                                              val loc = s (eappsleft, eexpright)
                                          in
                                              (EApp ((EVar (["Basis"], "Cons", Infer), loc),
-                                                    (ERecord [((CName "1", loc),
-                                                               eapps),
-                                                              ((CName "2", loc),
-                                                               eexp)], loc)), loc)
+                                                    (ERecord ([((CName "1", loc),
+                                                                eapps),
+                                                               ((CName "2", loc),
+                                                                eexp)], false), loc)), loc)
                                          end)
 
-bind   : SYMBOL LARROW eapps            (SYMBOL, NONE, eapps)
+bind   : eapps LARROW eapps             (patternOut eapps1, NONE, eapps2)
        | eapps                          (let
                                              val loc = s (eappsleft, eappsright)
                                          in
-                                             ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
+                                             ((PVar "_", loc), SOME (TRecord (CRecord [], loc), loc), eapps)
                                          end)
 
 eargs  : earg                           (earg)
@@ -1289,7 +1328,7 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
                                          in
                                              (ERecord (ListUtil.mapi (fn (i, e) =>
                                                                          ((CName (Int.toString (i + 1)), loc),
-                                                                          e)) etuple), loc)
+                                                                          e)) etuple, false), loc)
                                          end)
 
        | path                           (EVar (#1 path, #2 path, Infer), s (pathleft, pathright))
@@ -1299,7 +1338,8 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
        | AT cpath                       (EVar (#1 cpath, #2 cpath, TypesOnly), s (ATleft, cpathright))
        | AT AT cpath                    (EVar (#1 cpath, #2 cpath, DontInfer), s (AT1left, cpathright))
        | LBRACE rexp RBRACE             (ERecord rexp, s (LBRACEleft, RBRACEright))
-       | UNIT                           (ERecord [], s (UNITleft, UNITright))
+       | LBRACE RBRACE                  (ERecord ([], false), s (LBRACEleft, RBRACEright))
+       | UNIT                           (ERecord ([], false), s (UNITleft, UNITright))
 
        | INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
@@ -1386,7 +1426,7 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
                                                                        ^ " vs. " ^ Int.toString (length sqlexps) ^ ")")
                                              else
                                                  ();
-                                             (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc)
+                                             (EApp (e, (ERecord (ListPair.zip (fields, sqlexps), false), loc)), loc)
                                          end)
        | LPAREN enterDml UPDATE texp SET fsets CWHERE sqlexp leaveDml RPAREN
                                         (let
@@ -1394,7 +1434,7 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
 
                                              val e = (EVar (["Basis"], "update", Infer), loc)
                                              val e = (ECApp (e, (CWild (KRecord (KType, loc), loc), loc)), loc)
-                                             val e = (EApp (e, (ERecord fsets, loc)), loc)
+                                             val e = (EApp (e, (ERecord (fsets, false), loc)), loc)
                                              val e = (EApp (e, texp), loc)
                                          in
                                              (EApp (e, sqlexp), loc)
@@ -1486,9 +1526,9 @@ rpat   : CSYMBOL EQ pat                 ([(CSYMBOL, pat)], false)
 ptuple : pat COMMA pat                  ([pat1, pat2])
        | pat COMMA ptuple               (pat :: ptuple)
 
-rexp   :                                ([])
-       | ident EQ eexp                  ([(ident, eexp)])
-       | ident EQ eexp COMMA rexp       ((ident, eexp) :: rexp)
+rexp   : DOTDOTDOT                      ([], true)
+       | ident EQ eexp                  ([(ident, eexp)], false)
+       | ident EQ eexp COMMA rexp       ((ident, eexp) :: #1 rexp, #2 rexp)
 
 xml    : xmlOne xml                     (let
                                              val pos = s (xmlOneleft, xmlright)
@@ -1626,9 +1666,9 @@ tag    : tagHead attrs                  (let
                                                                 ((CName "Data", pos), datas') :: #6 attrs
                                                             end
 
-                                             val e = (EApp (e, (ERecord atts, pos)), pos)
+                                             val e = (EApp (e, (ERecord (atts, false), pos)), pos)
                                              val e = (EApp (e, (EApp (#2 tagHead,
-                                                                      (ERecord [], pos)), pos)), pos)
+                                                                      (ERecord ([], false), pos)), pos)), pos)
                                          in
                                              (tagHead, #1 attrs, #2 attrs, e)
                                          end)
@@ -1708,14 +1748,14 @@ attrv  : INT                            (EPrim (Prim.Int INT), s (INTleft, INTri
 query  : query1 obopt lopt ofopt        (let
                                              val loc = s (query1left, query1right)
 
-                                             val re = (ERecord [((CName "Rows", loc),
-                                                                 query1),
-                                                                ((CName "OrderBy", loc),
-                                                                 obopt),
-                                                                ((CName "Limit", loc),
-                                                                 lopt),
-                                                                ((CName "Offset", loc),
-                                                                 ofopt)], loc)
+                                             val re = (ERecord ([((CName "Rows", loc),
+                                                                  query1),
+                                                                 ((CName "OrderBy", loc),
+                                                                  obopt),
+                                                                 ((CName "Limit", loc),
+                                                                  lopt),
+                                                                 ((CName "Offset", loc),
+                                                                  ofopt)], false), loc)
                                          in
                                              (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
                                          end)
@@ -1796,21 +1836,21 @@ query1 : SELECT dopt select FROM tables wopt gopt hopt
                                              val e = (EVar (["Basis"], "sql_query1", Infer), loc)
                                              val e = (ECApp (e, (CRecord (map (fn nm => (nm, (CUnit, loc))) empties),
                                                                  loc)), loc)
-                                             val re = (ERecord [((CName "Distinct", loc),
-                                                                 dopt),
-                                                                ((CName "From", loc),
-                                                                 #2 tables),
-                                                                ((CName "Where", loc),
-                                                                 wopt),
-                                                                ((CName "GroupBy", loc),
-                                                                 grp),
-                                                                ((CName "Having", loc),
-                                                                 hopt),
-                                                                ((CName "SelectFields", loc),
-                                                                 (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
-                                                                         sel), loc)),
-                                                                ((CName "SelectExps", loc),
-                                                                 (ERecord exps, loc))], loc)
+                                             val re = (ERecord ([((CName "Distinct", loc),
+                                                                  dopt),
+                                                                 ((CName "From", loc),
+                                                                  #2 tables),
+                                                                 ((CName "Where", loc),
+                                                                  wopt),
+                                                                 ((CName "GroupBy", loc),
+                                                                  grp),
+                                                                 ((CName "Having", loc),
+                                                                  hopt),
+                                                                 ((CName "SelectFields", loc),
+                                                                  (ECApp ((EVar (["Basis"], "sql_subset", Infer), loc),
+                                                                          sel), loc)),
+                                                                 ((CName "SelectExps", loc),
+                                                                  (ERecord (exps, false), loc))], false), loc)
 
                                              val e = (EApp (e, re), loc)
                                          in
diff --git a/tests/bindpat.ur b/tests/bindpat.ur
new file mode 100644
index 00000000..bca4bd41
--- /dev/null
+++ b/tests/bindpat.ur
@@ -0,0 +1,6 @@
+fun main () : transaction page =
+  (a, b) <- return (1, 2);
+  {C = c, ...} <- return {C = "hi", D = False};
+  d <- return 2.34;
+  {1 = e, 2 = f} <- return (8, 9);
+  return <xml>{[a]}, {[b]}, {[c]}, {[d]}, {[e]}, {[f]}</xml>