summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/manual.tex2
-rw-r--r--src/elab_err.sig1
-rw-r--r--src/elab_err.sml4
-rw-r--r--src/elaborate.sml7
-rw-r--r--src/source.sml2
-rw-r--r--src/source_print.sml22
-rw-r--r--src/urweb.grm134
-rw-r--r--tests/bindpat.ur6
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>
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-25 05:01:16 +0000