Mercurial > urweb
changeset 754:8688e01ae469
A view query works
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 28 Apr 2009 15:04:37 -0400 |
| parents | d484df4e841a |
| children | 58d8f877e1ee |
| files | src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/elab.sml src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/elisp/urweb-mode.el src/expl.sml src/expl_env.sml src/expl_print.sml src/explify.sml src/mono.sml src/mono_env.sml src/mono_opt.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/prepare.sml src/reduce.sml src/reduce_local.sml src/shake.sml src/source.sml src/source_print.sml src/unnest.sml src/urweb.grm src/urweb.lex tests/view.ur tests/view.urp tests/view.urs |
| diffstat | 38 files changed, 324 insertions(+), 39 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/cjr.sml Tue Apr 28 15:04:37 2009 -0400 @@ -107,6 +107,7 @@ | DTable of string * (string * typ) list * string * (string * string) list | DSequence of string + | DView of string * (string * typ) list * string | DDatabase of {name : string, expunge : int, initialize : int} | DPreparedStatements of (string * int) list
--- a/src/cjr_env.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/cjr_env.sml Tue Apr 28 15:04:37 2009 -0400 @@ -164,6 +164,7 @@ end) env vis | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env
--- a/src/cjr_print.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/cjr_print.sml Tue Apr 28 15:04:37 2009 -0400 @@ -2069,6 +2069,15 @@ string x, string " */", newline] + | DView (x, _, s) => box [string "/* SQL view ", + string x, + space, + string "AS", + space, + string s, + space, + string " */", + newline] | DDatabase {name, expunge, initialize} => box [string "static void uw_db_validate(uw_context);", newline, @@ -3089,6 +3098,17 @@ string ";", newline, newline] + | DView (s, xts, q) => + box [string "CREATE VIEW", + space, + string s, + space, + string "AS", + space, + string q, + string ";", + newline, + newline] | _ => box [] in (pp, E.declBinds env dAll)
--- a/src/cjrize.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/cjrize.sml Tue Apr 28 15:04:37 2009 -0400 @@ -562,6 +562,34 @@ end | L.DSequence s => (SOME (L'.DSequence s, loc), NONE, sm) + | L.DView (s, xts, e) => + let + val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + in + ((x, t), sm) + end) sm xts + + fun flatten e = + case #1 e of + L.ERecord [] => [] + | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 + | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; + Print.prefaces "Undetermined constraint" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + []) + + val e = case #1 e of + L.EPrim (Prim.String s) => s + | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined"; + Print.prefaces "Undetermined VIEW query" + [("e", MonoPrint.p_exp MonoEnv.empty e)]; + "") + in + (SOME (L'.DView (s, xts, e), loc), NONE, sm) + end | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
--- a/src/core.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/core.sml Tue Apr 28 15:04:37 2009 -0400 @@ -130,6 +130,7 @@ | DExport of export_kind * int | DTable of string * int * con * string * exp * con * exp * con | DSequence of string * int * string + | DView of string * int * string * exp * con | DDatabase of string | DCookie of string * int * con * string | DStyle of string * int * string
--- a/src/core_env.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/core_env.sml Tue Apr 28 15:04:37 2009 -0400 @@ -327,6 +327,13 @@ in pushENamed env x n t NONE s end + | DView (x, n, s, _, c) => + let + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct NONE s + end | DDatabase _ => env | DCookie (x, n, c, s) => let
--- a/src/core_print.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/core_print.sml Tue Apr 28 15:04:37 2009 -0400 @@ -566,6 +566,13 @@ string "as", space, string s] + | DView (x, n, s, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DDatabase s => box [string "database", space, string s]
--- a/src/core_util.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/core_util.sml Tue Apr 28 15:04:37 2009 -0400 @@ -946,6 +946,12 @@ fn cc' => (DTable (x, n, c', s, pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll + | DView (x, n, s, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (x, n, s, e', c'), loc))) | DDatabase _ => S.return2 dAll | DCookie (x, n, c, s) => S.map2 (mfc ctx c, @@ -1082,6 +1088,14 @@ in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DView (x, n, s, _, c) => + let + val loc = #2 d' + val ct = (CFfi ("Basis", "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, n, ct, NONE, s)) + end | DDatabase _ => ctx | DCookie (x, n, c, s) => let @@ -1154,6 +1168,7 @@ | DExport _ => count | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) + | DView (_, n, _, _, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) | DStyle (_, n, _) => Int.max (n, count)) 0
--- a/src/corify.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/corify.sml Tue Apr 28 15:04:37 2009 -0400 @@ -992,6 +992,13 @@ in ([(L'.DSequence (x, n, s), loc)], st) end + | L.DView (_, x, n, e, c) => + let + val (st, n) = St.bindVal st x n + val s = relify (doRestify (mods, x)) + in + ([(L'.DView (x, n, s, corifyExp st e, corifyCon st c), loc)], st) + end | L.DDatabase s => ([(L'.DDatabase s, loc)], st) @@ -1063,6 +1070,7 @@ | L.DExport _ => n | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') + | L.DView (_, _, n', _, _) => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') | L.DStyle (_, _, n') => Int.max (n, n'))
--- a/src/elab.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/elab.sml Tue Apr 28 15:04:37 2009 -0400 @@ -165,6 +165,7 @@ | DExport of int * sgn * str | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int + | DView of int * string * int * exp * con | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con
--- a/src/elab_env.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/elab_env.sml Tue Apr 28 15:04:37 2009 -0400 @@ -591,6 +591,22 @@ exception Bad of con * con +val hasUnif = U.Con.exists {kind = fn _ => false, + con = fn CUnif (_, _, _, ref NONE) => true + | _ => false} + +fun startsWithUnif c = + let + fun firstArg (c, acc) = + case #1 c of + CApp (f, x) => firstArg (f, SOME x) + | _ => acc + in + case firstArg (c, NONE) of + NONE => false + | SOME x => hasUnif x + end + fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = let fun resolve c = @@ -671,34 +687,37 @@ tryGrounds (#ground class) end in - case #1 c of - TRecord c => - (case #1 (hnorm c) of - CRecord (_, xts) => - let - fun resolver (xts, acc) = - case xts of - [] => SOME (ERecord acc, #2 c) - | (x, t) :: xts => - let - val t = hnorm t + if startsWithUnif c then + NONE + else + case #1 c of + TRecord c => + (case #1 (hnorm c) of + CRecord (_, xts) => + let + fun resolver (xts, acc) = + case xts of + [] => SOME (ERecord acc, #2 c) + | (x, t) :: xts => + let + val t = hnorm t - val t = case t of - (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) - | _ => t - in - case resolve t of - NONE => NONE - | SOME e => resolver (xts, (x, e, t) :: acc) - end - in - resolver (xts, []) - end - | _ => NONE) - | _ => - case class_head_in c of - SOME f => doHead f - | _ => NONE + val t = case t of + (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc) + | _ => t + in + case resolve t of + NONE => NONE + | SOME e => resolver (xts, (x, e, t) :: acc) + end + in + resolver (xts, []) + end + | _ => NONE) + | _ => + case class_head_in c of + SOME f => doHead f + | _ => NONE end in resolve @@ -1482,6 +1501,13 @@ in pushENamedAs env x n t end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamedAs env x n ct + end | DClass (x, n, k, c) => let val k = (KArrow (k, (KType, loc)), loc)
--- a/src/elab_print.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/elab_print.sml Tue Apr 28 15:04:37 2009 -0400 @@ -758,6 +758,13 @@ | DSequence (_, x, n) => box [string "sequence", space, p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DClass (x, n, k, c) => box [string "class", space, p_named x n,
--- a/src/elab_util.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/elab_util.sml Tue Apr 28 15:04:37 2009 -0400 @@ -791,6 +791,13 @@ end | DSequence (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (n, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + bind (ctx, NamedE (x, ct)) + end | DClass (x, n, k, _) => bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))) | DDatabase _ => ctx @@ -899,6 +906,12 @@ fn cc' => (DTable (tn, x, n, c', pe', pc', ce', cc'), loc)))))) | DSequence _ => S.return2 dAll + | DView (tn, x, n, e, c) => + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx c, + fn c' => + (DView (tn, x, n, e', c'), loc))) | DClass (x, n, k, c) => S.bind2 (mfk ctx k, @@ -1051,6 +1064,7 @@ | DExport _ => 0 | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) + | DView (n1, _, n2, _, _) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) | DStyle (n1, _, n2) => Int.max (n1, n2)
--- a/src/elaborate.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/elaborate.sml Tue Apr 28 15:04:37 2009 -0400 @@ -803,19 +803,22 @@ handle GuessFailure => false end - val (fs1, fs2, others1, others2) = + val (fs1, fs2, others1, others2, unifs1, unifs2) = case (fs1, fs2, others1, others2, unifs1, unifs2) of ([], _, [other1], [], [], _) => if isGuessable (other1, fs2, unifs2) then - ([], [], [], []) + ([], [], [], [], [], []) else - (fs1, fs2, others1, others2) + (fs1, fs2, others1, others2, unifs1, unifs2) | (_, [], [], [other2], _, []) => if isGuessable (other2, fs1, unifs1) then - ([], [], [], []) + ([], [], [], [], [], []) else - (fs1, fs2, others1, others2) - | _ => (fs1, fs2, others1, others2) + (prefaces "Not guessable" [("other2", p_con env other2), + ("fs1", p_con env (L'.CRecord (k, fs1), loc)), + ("#unifs1", PD.string (Int.toString (length unifs1)))]; + (fs1, fs2, others1, others2, unifs1, unifs2)) + | _ => (fs1, fs2, others1, others2, unifs1, unifs2) (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) @@ -849,7 +852,7 @@ fun unfold (dom, ran, f, r, c) = let fun unfold (r, c) = - case #1 c of + case #1 (hnormCon env c) of L'.CRecord (_, []) => unifyCons env r (L'.CRecord (dom, []), loc) | L'.CRecord (_, [(x, v)]) => let @@ -878,8 +881,7 @@ unfold (r2, c2'); unifyCons env r (L'.CConcat (r1, r2), loc) end - | L'.CUnif (_, _, _, ref (SOME c)) => unfold (r, c) - | L'.CUnif (_, _, _, ur as ref NONE) => + | L'.CUnif (_, _, _, ur) => let val ur' = cunif (loc, (L'.KRecord dom, loc)) in @@ -1935,6 +1937,8 @@ fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) +fun viewOf () = (L'.CModProj (!basis_r, [], "sql_view"), ErrorMsg.dummySpan) +fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) @@ -2434,6 +2438,8 @@ [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), (L'.CConcat (pc, cc), loc)), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] + | L'.DView (tn, x, n, _, c) => + [(L'.SgiVal (x, n, (L'.CApp (viewOf (), c), loc)), loc)] | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] @@ -3405,6 +3411,29 @@ in ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) end + | L.DView (x, e) => + let + val (e', t, gs') = elabExp (env, denv) e + + val k = (L'.KRecord (L'.KType, loc), loc) + val fs = cunif (loc, k) + val ts = cunif (loc, (L'.KRecord k, loc)) + val tf = (L'.CApp ((L'.CMap (k, k), loc), + (L'.CAbs ("_", k, (L'.CRecord ((L'.KType, loc), []), loc)), loc)), loc) + val ts = (L'.CApp (tf, ts), loc) + + val cv = viewOf () + val cv = (L'.CApp (cv, fs), loc) + val (env', n) = E.pushENamed env x cv + + val ct = queryOf () + val ct = (L'.CApp (ct, ts), loc) + val ct = (L'.CApp (ct, fs), loc) + in + checkCon env e' t ct; + ([(L'.DView (!basis_r, x, n, e', fs), loc)], + (env', denv, gs' @ gs)) + end | L.DClass (x, k, c) => let
--- a/src/elisp/urweb-mode.el Tue Apr 28 14:02:23 2009 -0400 +++ b/src/elisp/urweb-mode.el Tue Apr 28 15:04:37 2009 -0400 @@ -137,7 +137,7 @@ "fun" "functor" "if" "include" "of" "open" "let" "in" "rec" "sequence" "sig" "signature" "cookie" "style" - "struct" "structure" "table" "then" "type" "val" "where" + "struct" "structure" "table" "view" "then" "type" "val" "where" "with" "Name" "Type" "Unit")
--- a/src/expl.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/expl.sml Tue Apr 28 15:04:37 2009 -0400 @@ -143,6 +143,7 @@ | DExport of int * sgn * str | DTable of int * string * int * con * exp * con * exp * con | DSequence of int * string * int + | DView of int * string * int * exp * con | DDatabase of string | DCookie of int * string * int * con | DStyle of int * string * int
--- a/src/expl_env.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/expl_env.sml Tue Apr 28 15:04:37 2009 -0400 @@ -312,6 +312,13 @@ in pushENamed env x n t end + | DView (tn, x, n, _, c) => + let + val ct = (CModProj (tn, [], "sql_view"), loc) + val ct = (CApp (ct, c), loc) + in + pushENamed env x n ct + end | DDatabase _ => env | DCookie (tn, x, n, c) => let
--- a/src/expl_print.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/expl_print.sml Tue Apr 28 15:04:37 2009 -0400 @@ -681,6 +681,13 @@ | DSequence (_, x, n) => box [string "sequence", space, p_named x n] + | DView (_, x, n, e, _) => box [string "view", + space, + p_named x n, + space, + string "as", + space, + p_exp env e] | DDatabase s => box [string "database", space, string s]
--- a/src/explify.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/explify.sml Tue Apr 28 15:04:37 2009 -0400 @@ -182,6 +182,8 @@ SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp pe, explifyCon pc, explifyExp ce, explifyCon cc), loc) + | L.DView (nt, x, n, e, c) => + SOME (L'.DView (nt, x, n, explifyExp e, explifyCon c), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc)
--- a/src/mono.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/mono.sml Tue Apr 28 15:04:37 2009 -0400 @@ -127,6 +127,7 @@ | DTable of string * (string * typ) list * exp * exp | DSequence of string + | DView of string * (string * typ) list * exp | DDatabase of {name : string, expunge : int, initialize : int} | DJavaScript of string
--- a/src/mono_env.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/mono_env.sml Tue Apr 28 15:04:37 2009 -0400 @@ -109,6 +109,7 @@ | DExport _ => env | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DJavaScript _ => env | DCookie _ => env
--- a/src/mono_opt.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/mono_opt.sml Tue Apr 28 15:04:37 2009 -0400 @@ -422,6 +422,31 @@ EPrim (Prim.String s) end + | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) => + let + fun uwify (cs, acc) = + case cs of + [] => String.concat (rev acc) + | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc) + | #"'" :: cs => + let + fun waitItOut (cs, acc) = + case cs of + [] => raise Fail "MonoOpt: Unterminated SQL string literal" + | #"'" :: cs => uwify (cs, "'" :: acc) + | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc) + | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc) + | c :: cs => waitItOut (cs, str c :: acc) + in + waitItOut (cs, "'" :: acc) + end + | c :: cs => uwify (cs, str c :: acc) + + val s = uwify (String.explode s, []) + in + EPrim (Prim.String s) + end + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
--- a/src/mono_print.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/mono_print.sml Tue Apr 28 15:04:37 2009 -0400 @@ -438,6 +438,13 @@ | DSequence s => box [string "(* SQL sequence ", string s, string "*)"] + | DView (s, _, e) => box [string "(* SQL view ", + string s, + space, + string "as", + space, + p_exp env e, + string "*)"] | DDatabase {name, expunge, initialize} => box [string "database", space, string name,
--- a/src/mono_shake.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/mono_shake.sml Tue Apr 28 15:04:37 2009 -0400 @@ -57,6 +57,7 @@ | ((DExport _, _), acc) => acc | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc + | ((DView _, _), acc) => acc | ((DDatabase _, _), acc) => acc | ((DJavaScript _, _), acc) => acc | ((DCookie _, _), acc) => acc @@ -116,6 +117,7 @@ | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true + | (DView _, _) => true | (DDatabase _, _) => true | (DJavaScript _, _) => true | (DCookie _, _) => true
--- a/src/mono_util.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/mono_util.sml Tue Apr 28 15:04:37 2009 -0400 @@ -492,6 +492,10 @@ fn ce' => (DTable (s, xts, pe', ce'), loc))) | DSequence _ => S.return2 dAll + | DView (s, xts, e) => + S.map2 (mfe ctx e, + fn e' => + (DView (s, xts, e'), loc)) | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll | DCookie _ => S.return2 dAll @@ -575,6 +579,7 @@ | DExport _ => ctx | DTable _ => ctx | DSequence _ => ctx + | DView _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx | DCookie _ => ctx @@ -626,6 +631,7 @@ | DExport _ => count | DTable _ => count | DSequence _ => count + | DView _ => count | DDatabase _ => count | DJavaScript _ => count | DCookie _ => count
--- a/src/monoize.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/monoize.sml Tue Apr 28 15:04:37 2009 -0400 @@ -2938,6 +2938,24 @@ (L'.DVal (x, n, t', e_name, s), loc)]) end | L.DTable _ => poly () + | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) => + let + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val s = "uw_" ^ s + val e_name = (L'.EPrim (Prim.String s), loc) + + val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts + + val (e, fm) = monoExp (env, St.empty, fm) e + val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DView (s, xts, e), loc), + (L'.DVal (x, n, t', e_name, s), loc)]) + end + | L.DView _ => poly () | L.DSequence (x, n, s) => let val t = (L.CFfi ("Basis", "string"), loc)
--- a/src/prepare.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/prepare.sml Tue Apr 28 15:04:37 2009 -0400 @@ -266,6 +266,7 @@ | DTable _ => (d, sns) | DSequence _ => (d, sns) + | DView _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns)
--- a/src/reduce.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/reduce.sml Tue Apr 28 15:04:37 2009 -0400 @@ -467,6 +467,7 @@ exp (namedC, namedE) [] ce, con namedC [] cc), loc), st) | DSequence _ => (d, st) + | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
--- a/src/reduce_local.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/reduce_local.sml Tue Apr 28 15:04:37 2009 -0400 @@ -158,6 +158,7 @@ | DExport _ => d | DTable _ => d | DSequence _ => d + | DView _ => d | DDatabase _ => d | DCookie _ => d | DStyle _ => d
--- a/src/shake.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/shake.sml Tue Apr 28 15:04:37 2009 -0400 @@ -84,6 +84,8 @@ (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) + | ((DView (_, n, _, _, c), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) @@ -159,8 +161,9 @@ | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true + | (DView _, _) => true + | (DSequence _, _) => true | (DTable _, _) => true - | (DSequence _, _) => true | (DDatabase _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true) file
--- a/src/source.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/source.sml Tue Apr 28 15:04:37 2009 -0400 @@ -161,6 +161,7 @@ | DExport of str | DTable of string * con * exp * exp | DSequence of string + | DView of string * exp | DClass of string * kind * con | DDatabase of string | DCookie of string * con
--- a/src/source_print.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/source_print.sml Tue Apr 28 15:04:37 2009 -0400 @@ -621,6 +621,13 @@ | DSequence x => box [string "sequence", space, string x] + | DView (x, e) => box [string "view", + space, + string x, + space, + string "=", + space, + p_exp e] | DClass (x, k, c) => box [string "class", space, string x,
--- a/src/unnest.sml Tue Apr 28 14:02:23 2009 -0400 +++ b/src/unnest.sml Tue Apr 28 15:04:37 2009 -0400 @@ -404,6 +404,7 @@ | DExport _ => default () | DTable _ => default () | DSequence _ => default () + | DView _ => default () | DClass _ => default () | DDatabase _ => default () | DCookie _ => default ()
--- a/src/urweb.grm Tue Apr 28 14:02:23 2009 -0400 +++ b/src/urweb.grm Tue Apr 28 15:04:37 2009 -0400 @@ -195,7 +195,7 @@ | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL - | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE + | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW | COOKIE | STYLE | CASE | IF | THEN | ELSE @@ -438,6 +438,10 @@ | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt), s (TABLEleft, cstoptright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) + | VIEW SYMBOL EQ query ([(DView (SYMBOL, query), + s (VIEWleft, queryright))]) + | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp), + s (VIEWleft, RBRACEright))]) | CLASS SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) in @@ -674,6 +678,13 @@ in (SgiVal (SYMBOL, t), loc) end) + | VIEW SYMBOL COLON cexp (let + val loc = s (VIEWleft, cexpright) + val t = (CVar (["Basis"], "sql_view"), loc) + val t = (CApp (t, cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) | CLASS SYMBOL (let val loc = s (CLASSleft, SYMBOLright) val k = (KArrow ((KType, loc), (KType, loc)), loc)
--- a/src/urweb.lex Tue Apr 28 14:02:23 2009 -0400 +++ b/src/urweb.lex Tue Apr 28 15:04:37 2009 -0400 @@ -317,6 +317,7 @@ <INITIAL> "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); <INITIAL> "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); <INITIAL> "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); +<INITIAL> "view" => (Tokens.VIEW (pos yypos, pos yypos + size yytext)); <INITIAL> "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); <INITIAL> "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); <INITIAL> "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/view.ur Tue Apr 28 15:04:37 2009 -0400 @@ -0,0 +1,10 @@ +table t : { A : int, B : string } + +view v = SELECT t.A AS X FROM t + +fun main () = + rows <- queryX (SELECT * FROM v) + (fn r => <xml><li>{[r.V.X]}</li></xml>); + return <xml><body> + {rows} + </body></xml>