Mercurial > urweb
changeset 993:10114d7b7477
SELECT DISTINCT; eta expansion during Cjrization
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 06 Oct 2009 15:39:27 -0400 |
| parents | b825d843b22d |
| children | 7932d577cf78 |
| files | demo/more/versioned.ur demo/more/versioned.urp demo/more/versioned.urs demo/more/versioned1.ur demo/more/versioned1.urp demo/more/versioned1.urs lib/ur/basis.urs lib/ur/top.ur lib/ur/top.urs src/cjrize.sml src/elisp/urweb-mode.el src/mono_env.sig src/monoize.sml src/urweb.grm src/urweb.lex |
| diffstat | 15 files changed, 260 insertions(+), 11 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/versioned.ur Tue Oct 06 15:39:27 2009 -0400 @@ -0,0 +1,114 @@ +functor Make(M : sig + con key :: {Type} + con data :: {Type} + constraint key ~ data + constraint [When] ~ (key ++ data) + + val key : $(map sql_injectable key) + val data : $(map (fn t => {Inj : sql_injectable_prim t, + Eq : eq t}) data) + + val keyFolder : folder key + val dataFolder : folder data + end) = struct + con all = [When = time] ++ M.key ++ map option M.data + table t : all + + val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T) + + con dmeta = fn t => {Inj : sql_injectable_prim t, + Eq : eq t} + + fun keyRecd (r : $(M.key ++ M.data)) = + map2 [sql_injectable] [id] [sql_exp [] [] []] + (fn [t] => @sql_inject) + [_] M.keyFolder M.key (r --- M.data) + + fun insert r = dml (Basis.insert t + ({When = (SQL CURRENT_TIMESTAMP)} + ++ keyRecd r + ++ map2 [dmeta] [id] + [fn t => sql_exp [] [] [] (option t)] + (fn [t] x v => @sql_inject (@sql_option_prim x.Inj) + (Some v)) + [_] M.dataFolder M.data (r --- M.key))) + + fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool = + foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after] + => sql_exp [T = before ++ after] [] [] bool] + (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before] + (inj : sql_injectable t) (v : t) + (e : after :: {Type} -> [before ~ after] + => sql_exp [T = before ++ after] [] [] bool) + [after :: {Type}] [[nm = t] ++ before ~ after] => + (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after] !})) + (fn [after :: {Type}] [[] ~ after] => (SQL TRUE)) + [_] M.keyFolder M.key r + [_] ! + + fun current k = + let + fun current' timeOpt r = + let + val complete = foldR [option] [fn ts => option $ts] + (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r] + v r => + case (v, r) of + (Some v, Some r) => Some ({nm = v} ++ r) + | _ => None) + (Some {}) [_] M.dataFolder r + in + case complete of + Some r => return (Some r) + | None => + let + val filter = case timeOpt of + None => (WHERE TRUE) + | Some time => (WHERE t.When < {[time]}) + in + ro <- oneOrNoRows (SELECT t.When, t.{{map option M.data}} + FROM t + WHERE {filter} + AND {keyExp k} + ORDER BY t.When DESC + LIMIT 1); + case ro of + None => return None + | Some r' => + let + val r = map2 [option] [option] [option] + (fn [t ::: Type] old new => + case old of + None => new + | Some _ => old) + [_] M.dataFolder r (r'.T -- #When) + in + current' (Some r'.T.When) r + end + end + end + in + current' None (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder) + end + + fun update r = + cur <- current (r --- M.data); + case cur of + None => error <xml>Tried to update nonexistent key</xml> + | Some cur => + let + val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)] + (fn [t] (meta : dmeta t) old new => + @sql_inject (@sql_option_prim meta.Inj) + (if @@eq [_] meta.Eq old new then + None + else + Some new)) + [_] M.dataFolder M.data cur (r --- M.key) + val r' = {When = (SQL CURRENT_TIMESTAMP)} + ++ keyRecd r + ++ r' + in + dml (Basis.insert t r') + end +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/versioned.urp Tue Oct 06 15:39:27 2009 -0400 @@ -0,0 +1,4 @@ + +$/option +$/list +versioned
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/versioned.urs Tue Oct 06 15:39:27 2009 -0400 @@ -0,0 +1,19 @@ +functor Make(M : sig + con key :: {Type} + con data :: {Type} + constraint key ~ data + constraint [When] ~ (key ++ data) + + val key : $(map sql_injectable key) + val data : $(map (fn t => {Inj : sql_injectable_prim t, + Eq : eq t}) data) + + val keyFolder : folder key + val dataFolder : folder data + end) : sig + val insert : $(M.key ++ M.data) -> transaction unit + val update : $(M.key ++ M.data) -> transaction unit + + val keys : transaction (list $M.key) + val current : $M.key -> transaction (option $M.data) +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/versioned1.ur Tue Oct 06 15:39:27 2009 -0400 @@ -0,0 +1,62 @@ +open Versioned.Make(struct + con key = [Id = int] + con data = [Nam = string, ShoeSize = int] + + val key = {Id = _} + val data = {Nam = {Inj = _, + Eq = _}, + ShoeSize = {Inj = _, + Eq = _}} + end) + +fun expandKey k = + name <- source ""; + shoeSize <- source ""; + return {Key = k, Nam = name, ShoeSize = shoeSize} + +fun main () = + ks0 <- keys; + ks0 <- List.mapM (fn r => expandKey r.Id) ks0; + ks <- source ks0; + + id <- source ""; + name <- source ""; + shoeSize <- source ""; + + return <xml><body> + <dyn signal={ks <- signal ks; + return (List.mapX (fn kr => <xml><div> + {[kr.Key]}: + <ctextbox source={kr.Nam}/> + <ctextbox size={5} source={kr.ShoeSize}/> + <button value="Latest" onclick={ro <- rpc (current {Id = kr.Key}); + case ro of + None => alert "Can't get it!" + | Some r => + set kr.Nam r.Nam; + set kr.ShoeSize (show r.ShoeSize)}/> + <button value="Update" onclick={name <- get kr.Nam; + shoeSize <- get kr.ShoeSize; + rpc (update {Id = kr.Key, + Nam = name, + ShoeSize = readError shoeSize}) + }/> + </div></xml>) ks)}/> + + <h2>Add one:</h2> + + <table> + <tr><th>Id:</th> <td><ctextbox size={5} source={id}/></td></tr> + <tr><th>Name:</th> <td><ctextbox source={name}/></td></tr> + <tr><th>Shoe size:</th> <td><ctextbox size={5} source={shoeSize}/></td></tr> + <tr><th><button value="Add" onclick={id <- get id; + name <- get name; + shoeSize <- get shoeSize; + rpc (insert {Id = readError id, Nam = name, + ShoeSize = readError shoeSize}); + + cur <- get ks; + kr <- expandKey (readError id); + set ks (kr :: cur)}/></th></tr> + </table> + </body></xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/versioned1.urp Tue Oct 06 15:39:27 2009 -0400 @@ -0,0 +1,6 @@ +debug +library versioned +database dbname=test +sql versioned1.sql + +versioned1
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/demo/more/versioned1.urs Tue Oct 06 15:39:27 2009 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- a/lib/ur/basis.urs Tue Oct 06 13:11:03 2009 -0400 +++ b/lib/ur/basis.urs Tue Oct 06 15:39:27 2009 -0400 @@ -291,7 +291,8 @@ -> grouped ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type} - -> {From : sql_from_items tables, + -> {Distinct : bool, + From : sql_from_items tables, Where : sql_exp tables [] [] bool, GroupBy : sql_subset tables grouped, Having : sql_exp grouped tables [] bool,
--- a/lib/ur/top.ur Tue Oct 06 13:11:03 2009 -0400 +++ b/lib/ur/top.ur Tue Oct 06 15:39:27 2009 -0400 @@ -92,6 +92,12 @@ fun txt [t] [ctx ::: {Unit}] [use ::: {Type}] (_ : show t) (v : t) = cdata (show v) +fun map0 [K] [tf :: K -> Type] (f : t :: K -> tf t) [r :: {K}] (fl : folder r) = + fl [fn r :: {K} => $(map tf r)] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc => + acc ++ {nm = f [t]}) + {} + fun mp [K] [tf1 :: K -> Type] [tf2 :: K -> Type] (f : t ::: K -> tf1 t -> tf2 t) [r :: {K}] (fl : folder r) = fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r)] (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r =>
--- a/lib/ur/top.urs Tue Oct 06 13:11:03 2009 -0400 +++ b/lib/ur/top.urs Tue Oct 06 15:39:27 2009 -0400 @@ -45,6 +45,9 @@ val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t -> xml ctx use [] +val map0 : K --> tf :: (K -> Type) + -> (t :: K -> tf t) + -> r :: {K} -> folder r -> $(map tf r) val mp : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> (t ::: K -> tf1 t -> tf2 t) -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r)
--- a/src/cjrize.sml Tue Oct 06 13:11:03 2009 -0400 +++ b/src/cjrize.sml Tue Oct 06 15:39:27 2009 -0400 @@ -520,9 +520,14 @@ in ((ax, dom) :: args, t, e) end - | (L'.TFun _, _) => - (ErrorMsg.errorAt loc "Function isn't explicit at code generation"; - ([], tAll, eAll)) + | (L'.TFun (dom, ran), _) => + let + val e = MonoEnv.liftExpInExp 0 eAll + val e = (L.EApp (e, (L.ERel 0, loc)), loc) + val (args, t, e) = unravel (ran, e) + in + (("x", dom) :: args, t, e) + end | _ => ([], tAll, eAll) val (args, ran, e) = unravel (t, e)
--- a/src/elisp/urweb-mode.el Tue Oct 06 13:11:03 2009 -0400 +++ b/src/elisp/urweb-mode.el Tue Oct 06 15:39:27 2009 -0400 @@ -144,7 +144,7 @@ "A regexp that matches any non-SQL keywords of Ur/Web.") (defconst urweb-sql-keywords-regexp - (urweb-syms-re "SELECT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY" + (urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY" "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT" "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX" "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
--- a/src/mono_env.sig Tue Oct 06 13:11:03 2009 -0400 +++ b/src/mono_env.sig Tue Oct 06 15:39:27 2009 -0400 @@ -48,5 +48,7 @@ val declBinds : env -> Mono.decl -> env val patBinds : env -> Mono.pat -> env val patBindsN : Mono.pat -> int + + val liftExpInExp : int -> Mono.exp -> Mono.exp end
--- a/src/monoize.sml Tue Oct 06 13:11:03 2009 -0400 +++ b/src/monoize.sml Tue Oct 06 15:39:27 2009 -0400 @@ -1771,6 +1771,7 @@ let fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) + val b = (L'.TFfi ("Basis", "bool"), loc) val un = (L'.TRecord [], loc) fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) @@ -1806,7 +1807,8 @@ (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps in ((L'.EAbs ("r", - (L'.TRecord [("From", s), + (L'.TRecord [("Distinct", b), + ("From", s), ("Where", s), ("GroupBy", un), ("Having", s), @@ -1815,6 +1817,22 @@ loc), s, strcat [sc "SELECT ", + (L'.ECase (gf "Distinct", + [((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, + NONE), loc), + (L'.EPrim (Prim.String "DISTINCT "), loc)), + ((L'.PCon (L'.Enum, + L'.PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, + NONE), loc), + (L'.EPrim (Prim.String ""), loc))], + {disc = b, result = s}), loc), strcatComma (map (fn (x, t) => strcat [ (L'.EField (gf "SelectExps", x), loc),
--- a/src/urweb.grm Tue Oct 06 13:11:03 2009 -0400 +++ b/src/urweb.grm Tue Oct 06 15:39:27 2009 -0400 @@ -208,7 +208,7 @@ | NOTAGS of string | BEGIN_TAG of string | END_TAG of string - | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING + | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING | UNION | INTERSECT | EXCEPT | LIMIT | OFFSET | ALL | TRUE | FALSE | CAND | OR | NOT @@ -314,6 +314,7 @@ | query of exp | query1 of exp + | dopt of exp | tables of con list * exp | fitem of con list * exp | tname of con @@ -625,7 +626,7 @@ commaOpt: () | COMMA () -pkopt : (EVar (["Basis"], "no_primary_key", Infer), ErrorMsg.dummySpan) +pkopt : (EVar (["Basis"], "no_primary_key", Infer), dummy) | PRIMARY KEY tnames (let val loc = s (PRIMARYleft, tnamesright) @@ -1410,8 +1411,12 @@ in (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc) end) - -query1 : SELECT select FROM tables wopt gopt hopt + +dopt : (EVar (["Basis"], "False", Infer), dummy) + | DISTINCT (EVar (["Basis"], "True", Infer), + s (DISTINCTleft, DISTINCTright)) + +query1 : SELECT dopt select FROM tables wopt gopt hopt (let val loc = s (SELECTleft, tablesright) @@ -1460,7 +1465,9 @@ end val e = (EVar (["Basis"], "sql_query1", Infer), loc) - val re = (ERecord [((CName "From", loc), + val re = (ERecord [((CName "Distinct", loc), + dopt), + ((CName "From", loc), #2 tables), ((CName "Where", loc), wopt),
--- a/src/urweb.lex Tue Oct 06 13:11:03 2009 -0400 +++ b/src/urweb.lex Tue Oct 06 15:39:27 2009 -0400 @@ -408,6 +408,7 @@ <INITIAL> "Unit" => (Tokens.KUNIT (pos yypos, pos yypos + size yytext)); <INITIAL> "SELECT" => (Tokens.SELECT (pos yypos, pos yypos + size yytext)); +<INITIAL> "DISTINCT" => (Tokens.DISTINCT (pos yypos, pos yypos + size yytext)); <INITIAL> "FROM" => (Tokens.FROM (pos yypos, pos yypos + size yytext)); <INITIAL> "AS" => (Tokens.AS (pos yypos, pos yypos + size yytext)); <INITIAL> "WHERE" => (Tokens.CWHERE (pos yypos, pos yypos + size yytext));