From 51f2a80dac5c3cd25a27fb5abfdfa50d813ab0b2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 28 Apr 2009 15:04:37 -0400 Subject: A view query works --- src/cjr.sml | 1 + src/cjr_env.sml | 1 + src/cjr_print.sml | 20 ++++++++++++ src/cjrize.sml | 28 +++++++++++++++++ src/core.sml | 1 + src/core_env.sml | 7 +++++ src/core_print.sml | 7 +++++ src/core_util.sml | 15 +++++++++ src/corify.sml | 8 +++++ src/elab.sml | 1 + src/elab_env.sml | 82 ++++++++++++++++++++++++++++++++----------------- src/elab_print.sml | 7 +++++ src/elab_util.sml | 14 +++++++++ src/elaborate.sml | 47 ++++++++++++++++++++++------ src/elisp/urweb-mode.el | 2 +- src/expl.sml | 1 + src/expl_env.sml | 7 +++++ src/expl_print.sml | 7 +++++ src/explify.sml | 2 ++ src/mono.sml | 1 + src/mono_env.sml | 1 + src/mono_opt.sml | 25 +++++++++++++++ src/mono_print.sml | 7 +++++ src/mono_shake.sml | 2 ++ src/mono_util.sml | 6 ++++ src/monoize.sml | 18 +++++++++++ src/prepare.sml | 1 + src/reduce.sml | 1 + src/reduce_local.sml | 1 + src/shake.sml | 5 ++- src/source.sml | 1 + src/source_print.sml | 7 +++++ src/unnest.sml | 1 + src/urweb.grm | 13 +++++++- src/urweb.lex | 1 + tests/view.ur | 10 ++++++ tests/view.urp | 5 +++ tests/view.urs | 1 + 38 files changed, 325 insertions(+), 40 deletions(-) create mode 100644 tests/view.ur create mode 100644 tests/view.urp create mode 100644 tests/view.urs diff --git a/src/cjr.sml b/src/cjr.sml index 559b7ada..d3fdbc22 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -107,6 +107,7 @@ datatype decl' = | 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 diff --git a/src/cjr_env.sml b/src/cjr_env.sml index 7f02a4e9..54dbea17 100644 --- a/src/cjr_env.sml +++ b/src/cjr_env.sml @@ -164,6 +164,7 @@ fun declBinds env (d, loc) = end) env vis | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env diff --git a/src/cjr_print.sml b/src/cjr_print.sml index c870c3ed..a09dd7f6 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2069,6 +2069,15 @@ fun p_decl env (dAll as (d, _) : decl) = 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 @@ fun p_sql env (ds, _) = 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) diff --git a/src/cjrize.sml b/src/cjrize.sml index ee2ecdb6..19aeee4e 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -562,6 +562,34 @@ fun cifyDecl ((d, loc), sm) = 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) diff --git a/src/core.sml b/src/core.sml index 01cf4ec7..131bcc6f 100644 --- a/src/core.sml +++ b/src/core.sml @@ -130,6 +130,7 @@ datatype decl' = | 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 diff --git a/src/core_env.sml b/src/core_env.sml index caf30349..0630fef2 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -327,6 +327,13 @@ fun declBinds env (d, loc) = 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 diff --git a/src/core_print.sml b/src/core_print.sml index 9c1c72cd..f2a42a7b 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -566,6 +566,13 @@ fun p_decl env (dAll as (d, _) : decl) = 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] diff --git a/src/core_util.sml b/src/core_util.sml index d05aaa72..ae956121 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -946,6 +946,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = 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 @@ fun mapfoldB (all as {bind, ...}) = 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 @@ val maxName = foldl (fn ((d, _) : decl, count) => | 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 diff --git a/src/corify.sml b/src/corify.sml index c1cd940e..f1895e19 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -992,6 +992,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = 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 @@ fun maxName ds = foldl (fn ((d, _), n) => | 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')) diff --git a/src/elab.sml b/src/elab.sml index f82a947d..555cc25c 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -165,6 +165,7 @@ datatype decl' = | 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 diff --git a/src/elab_env.sml b/src/elab_env.sml index 0184d0b1..efc2b74e 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -591,6 +591,22 @@ fun unifySubst (rs : con list) = 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 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) = 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 - - 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 + 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 end in resolve @@ -1482,6 +1501,13 @@ fun declBinds env (d, loc) = 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) diff --git a/src/elab_print.sml b/src/elab_print.sml index e6a2cccb..bbbd9f8d 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -758,6 +758,13 @@ fun p_decl env (dAll as (d, _) : decl) = | 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, diff --git a/src/elab_util.sml b/src/elab_util.sml index 0d78951b..f4cbc951 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -791,6 +791,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f 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 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f 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 @@ and maxNameDecl (d, _) = | 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) diff --git a/src/elaborate.sml b/src/elaborate.sml index 81fcbda1..b9378e1b 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -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 @@ val hnormSgn = E.hnormSgn 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 @@ and sgiOfDecl (d, loc) = [(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 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = 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 diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 2cd27fcc..7f4b0dee 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -137,7 +137,7 @@ See doc for the variable `urweb-mode-info'." "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") diff --git a/src/expl.sml b/src/expl.sml index e293c36b..cc40e8b4 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -143,6 +143,7 @@ datatype decl' = | 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 diff --git a/src/expl_env.sml b/src/expl_env.sml index 1e99b36b..2bb049a3 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -312,6 +312,13 @@ fun declBinds env (d, loc) = 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 diff --git a/src/expl_print.sml b/src/expl_print.sml index 167c6850..e6b28fea 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -681,6 +681,13 @@ fun p_decl env (dAll as (d, _) : decl) = | 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] diff --git a/src/explify.sml b/src/explify.sml index 6a33eabc..2e181771 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -182,6 +182,8 @@ fun explifyDecl (d, loc : EM.span) = 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) diff --git a/src/mono.sml b/src/mono.sml index e9d30181..7a789e2c 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,6 +127,7 @@ datatype decl' = | 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 diff --git a/src/mono_env.sml b/src/mono_env.sml index b3572fbe..739f2f89 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -109,6 +109,7 @@ fun declBinds env (d, loc) = | DExport _ => env | DTable _ => env | DSequence _ => env + | DView _ => env | DDatabase _ => env | DJavaScript _ => env | DCookie _ => env diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 19244e60..41724eb0 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -422,6 +422,31 @@ fun exp e = 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) diff --git a/src/mono_print.sml b/src/mono_print.sml index ffc1d4fe..a233b400 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -438,6 +438,13 @@ fun p_decl env (dAll as (d, _) : decl) = | 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, diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 0060d036..4764feb7 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -57,6 +57,7 @@ fun shake file = | ((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 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true + | (DView _, _) => true | (DDatabase _, _) => true | (DJavaScript _, _) => true | (DCookie _, _) => true diff --git a/src/mono_util.sml b/src/mono_util.sml index dd848ba6..caf96ac7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -492,6 +492,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = 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 @@ fun mapfoldB (all as {bind, ...}) = | DExport _ => ctx | DTable _ => ctx | DSequence _ => ctx + | DView _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx | DCookie _ => ctx @@ -626,6 +631,7 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable _ => count | DSequence _ => count + | DView _ => count | DDatabase _ => count | DJavaScript _ => count | DCookie _ => count diff --git a/src/monoize.sml b/src/monoize.sml index ccc5a851..a2048a7d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2938,6 +2938,24 @@ fun monoDecl (env, fm) (all as (d, loc)) = (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) diff --git a/src/prepare.sml b/src/prepare.sml index 25306e89..592b00bc 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -266,6 +266,7 @@ fun prepDecl (d as (_, loc), sns) = | DTable _ => (d, sns) | DSequence _ => (d, sns) + | DView _ => (d, sns) | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns) diff --git a/src/reduce.sml b/src/reduce.sml index 914f26c0..665c10b4 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -467,6 +467,7 @@ fun reduce file = 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) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 265cb2a4..6c25ebf3 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -158,6 +158,7 @@ fun reduce file = | DExport _ => d | DTable _ => d | DSequence _ => d + | DView _ => d | DDatabase _ => d | DCookie _ => d | DStyle _ => d diff --git a/src/shake.sml b/src/shake.sml index 787bfd2f..35af7436 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -84,6 +84,8 @@ fun shake file = (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 @@ fun shake file = | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis | (DExport _, _) => true - | (DTable _, _) => true + | (DView _, _) => true | (DSequence _, _) => true + | (DTable _, _) => true | (DDatabase _, _) => true | (DCookie _, _) => true | (DStyle _, _) => true) file diff --git a/src/source.sml b/src/source.sml index 6645ae75..9d3eea79 100644 --- a/src/source.sml +++ b/src/source.sml @@ -161,6 +161,7 @@ datatype decl' = | 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 diff --git a/src/source_print.sml b/src/source_print.sml index 58867f64..0f8b093b 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -621,6 +621,13 @@ fun p_decl ((d, _) : decl) = | 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, diff --git a/src/unnest.sml b/src/unnest.sml index c321b34d..51b66aa4 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -404,6 +404,7 @@ fun unnest file = | DExport _ => default () | DTable _ => default () | DSequence _ => default () + | DView _ => default () | DClass _ => default () | DDatabase _ => default () | DCookie _ => default () diff --git a/src/urweb.grm b/src/urweb.grm index ce078279..da817ab3 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -195,7 +195,7 @@ datatype attr = Class of exp | Normal of con * exp | 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 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | 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 @@ sgi : CON SYMBOL DCOLON kind ((SgiConAbs (SYMBOL, kind), s (CONleft, 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) diff --git a/src/urweb.lex b/src/urweb.lex index bb9004a6..85cf3bcf 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -317,6 +317,7 @@ notags = [^<{\n]+; "export" => (Tokens.EXPORT (pos yypos, pos yypos + size yytext)); "table" => (Tokens.TABLE (pos yypos, pos yypos + size yytext)); "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); + "view" => (Tokens.VIEW (pos yypos, pos yypos + size yytext)); "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); diff --git a/tests/view.ur b/tests/view.ur new file mode 100644 index 00000000..36d77deb --- /dev/null +++ b/tests/view.ur @@ -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 =>
  • {[r.V.X]}
    • ); + return + {rows} + diff --git a/tests/view.urp b/tests/view.urp new file mode 100644 index 00000000..3528ec9d --- /dev/null +++ b/tests/view.urp @@ -0,0 +1,5 @@ +debug +database dbname=view +sql view.sql + +view diff --git a/tests/view.urs b/tests/view.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/view.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3