Mercurial > urweb

comparison demo/more/versioned.ur @ 993:10114d7b7477

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
SELECT DISTINCT; eta expansion during Cjrization
author Adam Chlipala <adamc@hcoop.net>
date Tue, 06 Oct 2009 15:39:27 -0400
parents
children 166ea3944b91
comparison
equal deleted inserted replaced
992:b825d843b22d 993:10114d7b7477
1 functor Make(M : sig
2 con key :: {Type}
3 con data :: {Type}
4 constraint key ~ data
5 constraint [When] ~ (key ++ data)
6
7 val key : $(map sql_injectable key)
8 val data : $(map (fn t => {Inj : sql_injectable_prim t,
9 Eq : eq t}) data)
10
11 val keyFolder : folder key
12 val dataFolder : folder data
13 end) = struct
14 con all = [When = time] ++ M.key ++ map option M.data
15 table t : all
16
17 val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
18
19 con dmeta = fn t => {Inj : sql_injectable_prim t,
20 Eq : eq t}
21
22 fun keyRecd (r : $(M.key ++ M.data)) =
23 map2 [sql_injectable] [id] [sql_exp [] [] []]
24 (fn [t] => @sql_inject)
25 [_] M.keyFolder M.key (r --- M.data)
26
27 fun insert r = dml (Basis.insert t
28 ({When = (SQL CURRENT_TIMESTAMP)}
29 ++ keyRecd r
30 ++ map2 [dmeta] [id]
31 [fn t => sql_exp [] [] [] (option t)]
32 (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
33 (Some v))
34 [_] M.dataFolder M.data (r --- M.key)))
35
36 fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool =
37 foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after]
38 => sql_exp [T = before ++ after] [] [] bool]
39 (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before]
40 (inj : sql_injectable t) (v : t)
41 (e : after :: {Type} -> [before ~ after]
42 => sql_exp [T = before ++ after] [] [] bool)
43 [after :: {Type}] [[nm = t] ++ before ~ after] =>
44 (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after] !}))
45 (fn [after :: {Type}] [[] ~ after] => (SQL TRUE))
46 [_] M.keyFolder M.key r
47 [_] !
48
49 fun current k =
50 let
51 fun current' timeOpt r =
52 let
53 val complete = foldR [option] [fn ts => option $ts]
54 (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r]
55 v r =>
56 case (v, r) of
57 (Some v, Some r) => Some ({nm = v} ++ r)
58 | _ => None)
59 (Some {}) [_] M.dataFolder r
60 in
61 case complete of
62 Some r => return (Some r)
63 | None =>
64 let
65 val filter = case timeOpt of
66 None => (WHERE TRUE)
67 | Some time => (WHERE t.When < {[time]})
68 in
69 ro <- oneOrNoRows (SELECT t.When, t.{{map option M.data}}
70 FROM t
71 WHERE {filter}
72 AND {keyExp k}
73 ORDER BY t.When DESC
74 LIMIT 1);
75 case ro of
76 None => return None
77 | Some r' =>
78 let
79 val r = map2 [option] [option] [option]
80 (fn [t ::: Type] old new =>
81 case old of
82 None => new
83 | Some _ => old)
84 [_] M.dataFolder r (r'.T -- #When)
85 in
86 current' (Some r'.T.When) r
87 end
88 end
89 end
90 in
91 current' None (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
92 end
93
94 fun update r =
95 cur <- current (r --- M.data);
96 case cur of
97 None => error <xml>Tried to update nonexistent key</xml>
98 | Some cur =>
99 let
100 val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)]
101 (fn [t] (meta : dmeta t) old new =>
102 @sql_inject (@sql_option_prim meta.Inj)
103 (if @@eq [_] meta.Eq old new then
104 None
105 else
106 Some new))
107 [_] M.dataFolder M.data cur (r --- M.key)
108 val r' = {When = (SQL CURRENT_TIMESTAMP)}
109 ++ keyRecd r
110 ++ r'
111 in
112 dml (Basis.insert t r')
113 end
114 end