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
|
con link = fn col_parent :: (Type * Type) => col_parent.1 -> transaction (option col_parent.2)
fun noParent [t ::: Type] (_ : t) : transaction (option unit) = return None
con meta = fn (col :: Type, parent :: Type) => {
Link : link (col, parent),
Inj : sql_injectable col
}
fun local [t :: Type] (inj : sql_injectable t) : meta (t, unit) =
{Link = noParent,
Inj = inj}
functor Table(M : sig
con cols :: {(Type * Type)}
val cols : $(map meta cols)
constraint [Id] ~ cols
val folder : folder cols
end) = struct
type id = int
con fs' = map fst M.cols
con fs = [Id = id] ++ fs'
type row' = $fs'
type row = $fs
fun resultsOut q = query q (fn r ls => return (r.T :: ls)) []
fun resultOut q = ro <- oneOrNoRows q; return (Option.mp (fn r => r .T) ro)
sequence s
table t : fs
val inj = _
val id = {Link = fn id => resultOut (SELECT * FROM t WHERE t.Id = {[id]}),
Inj = inj}
fun ensql [avail ::_] (r : row') : $(map (sql_exp avail [] [] disallow_window) fs') =
@map2 [meta] [fst] [fn ts :: (Type * Type) => sql_exp avail [] [] disallow_window ts.1]
(fn [ts] meta v => @sql_inject meta.Inj v)
M.folder M.cols r
fun create (r : row') =
id <- nextval s;
dml (insert t ({Id = sql_inject id} ++ ensql [[]] r));
return ({Id = id} ++ r)
fun delete r = dml (DELETE FROM t WHERE t.Id = {[r.Id]})
fun save r = dml (update [fs'] (ensql [[T = [Id = int] ++ map fst M.cols]] (r -- #Id)) t (WHERE T.Id = {[r.Id]}))
fun lookup id =
ro <- oneOrNoRows (SELECT * FROM t WHERE t.Id = {[id]});
return (Option.mp (fn r => r.T) ro)
val list = resultsOut (SELECT * FROM t)
con col = fn t => {Exp : sql_exp [T = fs] [] [] disallow_window t,
Inj : sql_injectable t}
val idCol = {Exp = sql_field [#T] [#Id], Inj = _}
con meta' = fn (fs :: {Type}) (col :: Type, parent :: Type) =>
{Col : {Exp : sql_exp [T = fs] [] [] disallow_window col,
Inj : sql_injectable col},
Parent : $fs -> transaction (option parent)}
val cols = @foldR [meta] [fn before => after :: {(Type * Type)} -> [before ~ after] =>
$(map (meta' (map fst (before ++ after))) before)]
(fn [nm :: Name] [ts :: (Type * Type)] [before :: {(Type * Type)}]
[[nm] ~ before] (meta : meta ts)
(acc : after :: {(Type * Type)} -> [before ~ after] =>
$(map (meta' (map fst (before ++ after))) before))
[after :: {(Type * Type)}] [[nm = ts] ++ before ~ after] =>
{nm = {Col = {Exp = sql_field [#T] [nm],
Inj = meta.Inj},
Parent = fn r => meta.Link r.nm}}
++ acc [[nm = ts] ++ after])
(fn [after :: {(Type * Type)}] [[] ~ after] => {})
M.folder M.cols
[[Id = (id, row)]] !
type filter = sql_exp [T = fs] [] [] disallow_window bool
fun find (f : filter) = resultOut (SELECT * FROM t WHERE {f})
fun search (f : filter) = resultsOut (SELECT * FROM t WHERE {f})
fun bin (b : t ::: Type -> sql_binary t t bool) [t] (c : col t) (v : t) =
sql_binary b c.Exp (@sql_inject c.Inj v)
val eq = @@bin @@sql_eq
val ne = @@bin @@sql_ne
val lt = @@bin @@sql_lt
val le = @@bin @@sql_le
val gt = @@bin @@sql_gt
val ge = @@bin @@sql_ge
fun bb (b : sql_binary bool bool bool) (f1 : filter) (f2 : filter) =
sql_binary b f1 f2
val _and = bb sql_and
val or = bb sql_or
end
|
