summaryrefslogtreecommitdiff
path: root/demo
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-10-06 15:39:27 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-10-06 15:39:27 -0400
commit8acfc38ef053ab673aad1c01b67a9ded9cdc3dff (patch)
treefa80b1891097e60c758ecb12fd8c441f37a03c85 /demo
parent1de883737e14d5b6dbd442c5f92ca6e97d9322b5 (diff)
SELECT DISTINCT; eta expansion during Cjrization
Diffstat (limited to 'demo')
-rw-r--r--demo/more/versioned.ur114
-rw-r--r--demo/more/versioned.urp4
-rw-r--r--demo/more/versioned.urs19
-rw-r--r--demo/more/versioned1.ur62
-rw-r--r--demo/more/versioned1.urp6
-rw-r--r--demo/more/versioned1.urs1
6 files changed, 206 insertions, 0 deletions
diff --git a/demo/more/versioned.ur b/demo/more/versioned.ur
new file mode 100644
index 00000000..cb93ef6c
--- /dev/null
+++ b/demo/more/versioned.ur
@@ -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
diff --git a/demo/more/versioned.urp b/demo/more/versioned.urp
new file mode 100644
index 00000000..a75d6c6a
--- /dev/null
+++ b/demo/more/versioned.urp
@@ -0,0 +1,4 @@
+
+$/option
+$/list
+versioned
diff --git a/demo/more/versioned.urs b/demo/more/versioned.urs
new file mode 100644
index 00000000..eb0a485e
--- /dev/null
+++ b/demo/more/versioned.urs
@@ -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
diff --git a/demo/more/versioned1.ur b/demo/more/versioned1.ur
new file mode 100644
index 00000000..506d2778
--- /dev/null
+++ b/demo/more/versioned1.ur
@@ -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>
diff --git a/demo/more/versioned1.urp b/demo/more/versioned1.urp
new file mode 100644
index 00000000..c24b3531
--- /dev/null
+++ b/demo/more/versioned1.urp
@@ -0,0 +1,6 @@
+debug
+library versioned
+database dbname=test
+sql versioned1.sql
+
+versioned1
diff --git a/demo/more/versioned1.urs b/demo/more/versioned1.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/demo/more/versioned1.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page