blob: d08ebcb028d81f4e866ef5ecaadc0c7b68350f7f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
functor Make(M : sig
con key :: {Type}
con data :: {Type}
constraint key ~ data
constraint [When, Version] ~ (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
type version = int
con all = [When = time, Version = version] ++ M.key ++ map option M.data
sequence s
table t : all
val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
fun keysAt vr = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t
WHERE t.Version <= {[vr]}) (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] [ident] [sql_exp [] [] []]
(fn [t] => @sql_inject)
M.keyFolder M.key (r --- M.data)
fun insert r =
vr <- nextval s;
dml (Basis.insert t
({Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
++ keyRecd r
++ @map2 [dmeta] [ident]
[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] [ident] [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
[_] !
datatype bound =
NoBound
| Lt of int
| Le of int
fun seek vro k =
let
fun current' vro 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 vro of
NoBound => (WHERE TRUE)
| Lt vr => (WHERE t.Version < {[vr]})
| Le vr => (WHERE t.Version <= {[vr]})
in
ro <- oneOrNoRows (SELECT t.Version, 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 -- #Version)
in
current' (Lt r'.T.Version) r
end
end
end
in
current' vro (@map0 [option] (fn [t :: Type] => None : option t) M.dataFolder)
end
val current = seek NoBound
fun archive vr = seek (Le vr)
fun update r =
cur <- current (r --- M.data);
case cur of
None => error <xml>Tried to update nonexistent key</xml>
| Some cur =>
vr <- nextval s;
let
val r' = @map3 [dmeta] [ident] [ident] [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' = {Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
++ keyRecd r
++ r'
in
dml (Basis.insert t r')
end
val updateTimes = List.mapQuery (SELECT t.Version, t.When
FROM t
ORDER BY t.When) (fn r => (r.T.Version, r.T.When))
end
|
