Mercurial > urweb
changeset 2009:799be3911ce3
Monadic bind supports patterns
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Fri, 02 May 2014 17:16:02 -0400 |
| parents | 93ff76058825 |
| children | 403f0cc65b9c |
| files | doc/manual.tex src/elab_err.sig src/elab_err.sml src/elaborate.sml src/source.sml src/source_print.sml src/urweb.grm tests/bindpat.ur |
| diffstat | 8 files changed, 121 insertions(+), 57 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/manual.tex Fri May 02 15:32:10 2014 -0400 +++ b/doc/manual.tex Fri May 02 17:16:02 2014 -0400 @@ -1442,6 +1442,8 @@ 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.
--- a/src/elab_err.sig Fri May 02 15:32:10 2014 -0400 +++ b/src/elab_err.sig Fri May 02 17:16:02 2014 -0400 @@ -81,6 +81,7 @@ | 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
--- a/src/elab_err.sml Fri May 02 15:32:10 2014 -0400 +++ b/src/elab_err.sml Fri May 02 17:16:02 2014 -0400 @@ -180,6 +180,7 @@ | 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 @@ (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 =
--- a/src/elaborate.sml Fri May 02 15:32:10 2014 -0400 +++ b/src/elaborate.sml Fri May 02 17:16:02 2014 -0400 @@ -2183,8 +2183,13 @@ (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
--- a/src/source.sml Fri May 02 15:32:10 2014 -0400 +++ b/src/source.sml Fri May 02 17:16:02 2014 -0400 @@ -125,7 +125,7 @@ | 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
--- a/src/source_print.sml Fri May 02 15:32:10 2014 -0400 +++ b/src/source_print.sml Fri May 02 17:16:02 2014 -0400 @@ -277,14 +277,20 @@ 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]
--- a/src/urweb.grm Fri May 02 15:32:10 2014 -0400 +++ b/src/urweb.grm Fri May 02 17:16:02 2014 -0400 @@ -322,6 +322,39 @@ (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 @@ | 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ | 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 @@ ^ " 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 @@ 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 @@ 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 @@ ((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 @@ 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 @@ 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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/bindpat.ur Fri May 02 17:16:02 2014 -0400 @@ -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>