adamc@990: con link = fn col_parent :: (Type * Type) => col_parent.1 -> transaction (option col_parent.2) adamc@990: fun noParent [t ::: Type] _ = return None adamc@987: adamc@990: con meta = fn col_parent :: (Type * Type) => { adamc@990: Link : link col_parent, adamc@990: Inj : sql_injectable col_parent.1 adamc@990: } adamc@987: 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@990: map2 [meta] [fst] [fn ts :: (Type * Type) => sql_exp avail [] [] ts.1] adamc@990: (fn [ts] meta v => @sql_inject meta.Inj v) adamc@988: [_] 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@990: 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@990: con meta' = fn (fs :: {Type}) (col_parent :: (Type * Type)) => adamc@990: {Col : {Exp : sql_exp [T = fs] [] [] col_parent.1, adamc@990: Inj : sql_injectable col_parent.1}, adamc@990: Parent : $fs -> transaction (option col_parent.2)} adamc@990: val cols = foldR [meta] [fn before => after :: {(Type * Type)} -> [before ~ after] => adamc@990: $(map (meta' (map fst (before ++ after))) before)] adamc@990: (fn [nm :: Name] [ts :: (Type * Type)] [before :: {(Type * Type)}] adamc@990: [[nm] ~ before] (meta : meta ts) adamc@990: (acc : after :: {(Type * Type)} -> [before ~ after] => adamc@990: $(map (meta' (map fst (before ++ after))) before)) adamc@990: [after :: {(Type * Type)}] [[nm = ts] ++ before ~ after] => adamc@990: {nm = {Col = {Exp = sql_field [#T] [nm], adamc@990: Inj = meta.Inj}, adamc@990: Parent = fn r => meta.Link r.nm}} adamc@990: ++ acc [[nm = ts] ++ after] !) adamc@990: (fn [after :: {(Type * Type)}] [[] ~ after] => {}) adamc@989: [_] M.folder M.cols adamc@990: [[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@989: val eq = bin @@sql_eq adamc@989: val ne = bin @@sql_ne adamc@989: val lt = bin @@sql_lt adamc@989: val le = bin @@sql_le adamc@989: val gt = bin @@sql_gt adamc@989: 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