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