adamc@915: con rawMeta = fn t :: Type => adamc@915: {New : transaction t, adamc@915: Inj : sql_injectable t} adamc@915: adamc@915: con colMeta' = fn (row :: {Type}) (t :: Type) => adamc@915: {Header : string, adamc@915: Project : $row -> transaction t, adamc@915: Update : $row -> t -> transaction ($row), adamc@915: Display : t -> xbody, adamc@915: Edit : t -> xbody, adamc@915: Validate : t -> signal bool} adamc@915: adamc@915: con colMeta = fn (row :: {Type}) (global_t :: (Type * Type)) => adamc@915: {Initialize : transaction global_t.1, adamc@915: Handlers : global_t.1 -> colMeta' row global_t.2} adamc@915: adamc@915: structure Direct = struct adamc@930: con metaBase = fn actual_input :: (Type * Type) => adamc@930: {Display : actual_input.2 -> xbody, adamc@930: Edit : actual_input.2 -> xbody, adamc@930: Initialize : actual_input.1 -> transaction actual_input.2, adamc@930: Parse : actual_input.2 -> signal (option actual_input.1)} adamc@930: adamc@930: datatype metaBoth actual input = adamc@930: NonNull of metaBase (actual, input) * metaBase (option actual, input) adamc@930: | Nullable of metaBase (actual, input) adamc@930: adamc@915: con meta = fn global_actual_input :: (Type * Type * Type) => adamc@915: {Initialize : transaction global_actual_input.1, adamc@915: Handlers : global_actual_input.1 adamc@930: -> metaBoth global_actual_input.2 global_actual_input.3} adamc@915: adamc@915: con editableState (ts :: (Type * Type * Type)) = (ts.1, ts.3) adamc@915: fun editable [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest) adamc@915: (editableState ts) = adamc@930: let adamc@930: fun doMr mr = {Header = name, adamc@930: Project = fn r => mr.Initialize r.nm, adamc@930: Update = fn r s => adamc@930: vo <- current (mr.Parse s); adamc@930: return (case vo of adamc@930: None => r adamc@930: | Some v => r -- nm ++ {nm = v}), adamc@930: Display = mr.Display, adamc@930: Edit = mr.Edit, adamc@930: Validate = fn s => vo <- mr.Parse s; return (Option.isSome vo)} adamc@930: in adamc@930: {Initialize = m.Initialize, adamc@930: Handlers = fn data => case m.Handlers data of adamc@930: NonNull (mr, _) => doMr mr adamc@930: | Nullable mr => doMr mr} adamc@930: end adamc@915: adamc@915: con readOnlyState (ts :: (Type * Type * Type)) = (ts.1, ts.3) adamc@915: fun readOnly [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest) adamc@915: (readOnlyState ts) = adamc@930: let adamc@930: fun doMr mr = {Header = name, adamc@930: Project = fn r => mr.Initialize r.nm, adamc@930: Update = fn r _ => return r, adamc@930: Display = mr.Display, adamc@930: Edit = mr.Display, adamc@930: Validate = fn _ => return True} adamc@930: in adamc@930: {Initialize = m.Initialize, adamc@930: Handlers = fn data => case m.Handlers data of adamc@930: NonNull (mr, _) => doMr mr adamc@930: | Nullable mr => doMr mr} adamc@930: end adamc@915: adamc@915: con metaBasic = fn actual_input :: (Type * Type) => adamc@930: {Display : actual_input.2 -> xbody, adamc@930: Edit : source actual_input.2 -> xbody, adamc@930: Initialize : actual_input.1 -> actual_input.2, adamc@930: InitializeNull : actual_input.2, adamc@930: IsNull : actual_input.2 -> bool, adamc@930: Parse : actual_input.2 -> option actual_input.1} adamc@915: adamc@915: con basicState = source adamc@915: fun basic [ts ::: (Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2) = adamc@915: {Initialize = return (), adamc@930: Handlers = fn () => NonNull ( adamc@930: {Display = fn s => , adamc@915: Edit = m.Edit, adamc@915: Initialize = fn v => source (m.Initialize v), adamc@930: Parse = fn s => v <- signal s; return (m.Parse v)}, adamc@930: {Display = fn s => , adamc@930: Edit = m.Edit, adamc@930: Initialize = fn v => source (case v of adamc@930: None => m.InitializeNull adamc@930: | Some v => m.Initialize v), adamc@930: Parse = fn s => v <- signal s; adamc@930: return (if m.IsNull v then adamc@930: Some None adamc@930: else adamc@930: case m.Parse v of adamc@930: None => None adamc@930: | Some v' => Some (Some v'))})} adamc@930: adamc@930: fun nullable [global] [actual] [input] (m : meta (global, actual, input)) = adamc@930: {Initialize = m.Initialize, adamc@930: Handlers = fn d => case m.Handlers d of adamc@930: Nullable _ => error Don't stack calls to Direct.nullable! adamc@930: | NonNull (_, ho) => Nullable ho} adamc@915: adamc@915: type intGlobal = unit adamc@915: type intInput = basicState string adamc@915: val int : meta (intGlobal, int, intInput) = adamc@915: basic {Display = fn s => {[s]}, adamc@915: Edit = fn s => , adamc@915: Initialize = fn n => show n, adamc@930: InitializeNull = "", adamc@930: IsNull = eq "", adamc@915: Parse = fn v => read v} adamc@915: adamc@915: type stringGlobal = unit adamc@915: type stringInput = basicState string adamc@915: val string : meta (stringGlobal, string, stringInput) = adamc@915: basic {Display = fn s => {[s]}, adamc@915: Edit = fn s => , adamc@915: Initialize = fn s => s, adamc@930: InitializeNull = "", adamc@930: IsNull = eq "", adamc@915: Parse = fn s => Some s} adamc@915: adamc@915: type boolGlobal = unit adamc@915: type boolInput = basicState bool adamc@915: val bool : meta (boolGlobal, bool, boolInput) = adamc@915: basic {Display = fn b => {[b]}, adamc@915: Edit = fn s => , adamc@915: Initialize = fn b => b, adamc@930: InitializeNull = False, adamc@930: IsNull = fn _ => False, adamc@915: Parse = fn b => Some b} adamc@915: adamc@915: functor Foreign (M : sig adamc@915: con row :: {Type} adamc@915: con t :: Type adamc@915: val show_t : show t adamc@915: val read_t : read t adamc@915: val eq_t : eq t adamc@915: val inj_t : sql_injectable t adamc@915: con nm :: Name adamc@915: constraint [nm] ~ row adamc@915: table tab : ([nm = t] ++ row) adamc@915: val render : $([nm = t] ++ row) -> string adamc@915: end) = struct adamc@915: open M adamc@915: adamc@915: con global = list (t * string) adamc@930: con input = source string * option (t * $row) adamc@915: adamc@915: val getChoices = List.mapQuery (SELECT * FROM tab AS T) adamc@915: (fn r => (r.T.nm, render r.T)) adamc@915: adamc@915: fun getChoice k = adamc@915: r <- oneRow (SELECT T.{{row}} FROM tab AS T WHERE T.{nm} = {[k]}); adamc@915: return r.T adamc@915: adamc@930: val meta : meta (global, M.t, input) = adamc@915: {Initialize = getChoices, adamc@915: Handlers = fn choices => adamc@930: NonNull ( adamc@930: {Display = fn (_, kr) => case kr of adamc@930: None => error Unexpected Foreign null adamc@930: | Some (k, r) => {[render ({nm = k} ++ r)]}, adamc@930: Edit = fn (s, kr) => adamc@915: adamc@915: {List.mapX (fn (k', rend) => adamc@930: False adamc@930: | Some (k, _) => adamc@930: k' = k}>{[rend]} adamc@915: ) adamc@915: choices} adamc@915: , adamc@915: Initialize = fn k => s <- source (show k); adamc@915: r <- rpc (getChoice k); adamc@930: return (s, Some (k, r)), adamc@930: Parse = fn (s, _) => k <- signal s; return (read k : option t)}, adamc@930: {Display = fn (_, kr) => case kr of adamc@930: None => NULL adamc@930: | Some (k, r) => {[render ({nm = k} ++ r)]}, adamc@930: Edit = fn (s, kr) => adamc@930: adamc@930: True adamc@930: | _ => False}>NULL adamc@930: {List.mapX (fn (k', rend) => adamc@930: False adamc@930: | Some (k, _) => adamc@930: k' = k}>{[rend]} adamc@930: ) adamc@930: choices} adamc@930: , adamc@930: Initialize = fn k => case k of adamc@930: None => adamc@930: s <- source ""; adamc@930: return (s, None) adamc@930: | Some k => adamc@930: s <- source (show k); adamc@930: r <- rpc (getChoice k); adamc@930: return (s, Some (k, r)), adamc@930: Parse = fn (s, _) => ks <- signal s; adamc@930: return (case ks of adamc@930: "" => Some None adamc@930: | _ => case read ks : option t of adamc@930: None => None adamc@930: | Some k => Some (Some k))})} adamc@915: end adamc@915: end adamc@915: adamc@915: con computedState = (unit, xbody) adamc@915: fun computed [row] [t] (_ : show t) name (f : $row -> t) : colMeta row computedState = adamc@915: {Initialize = return (), adamc@915: Handlers = fn () => {Header = name, adamc@915: Project = fn r => return {[f r]}, adamc@915: Update = fn r _ => return r, adamc@915: Display = fn x => x, adamc@915: Edit = fn _ => ..., adamc@915: Validate = fn _ => return True}} adamc@915: fun computedHtml [row] name (f : $row -> xbody) : colMeta row computedState = adamc@915: {Initialize = return (), adamc@915: Handlers = fn () => {Header = name, adamc@915: Project = fn r => return (f r), adamc@915: Update = fn r _ => return r, adamc@915: Display = fn x => x, adamc@915: Edit = fn _ => ..., adamc@915: Validate = fn _ => return True}} adamc@915: adamc@915: functor Make(M : sig adamc@915: con key :: {Type} adamc@915: con row :: {Type} adamc@915: constraint key ~ row adamc@915: table tab : (key ++ row) adamc@915: adamc@915: val raw : $(map rawMeta (key ++ row)) adamc@915: adamc@915: con cols :: {(Type * Type)} adamc@915: val cols : $(map (colMeta (key ++ row)) cols) adamc@915: adamc@915: val keyFolder : folder key adamc@915: val rowFolder : folder row adamc@915: val colsFolder : folder cols adamc@915: end) = struct adamc@915: open Grid.Make(struct adamc@915: val list = query (SELECT * FROM {{M.tab}} AS T) (fn r rs => return (r.T :: rs)) [] adamc@915: adamc@915: val wholeRow = @Folder.concat ! M.keyFolder M.rowFolder adamc@915: adamc@915: fun ensql [env] (r : $(M.key ++ M.row)) = adamc@915: map2 [rawMeta] [id] [sql_exp env [] []] adamc@915: (fn [t] meta v => @sql_inject meta.Inj v) adamc@915: [_] wholeRow M.raw r adamc@915: adamc@915: val new = adamc@915: row <- Monad.mapR [rawMeta] [id] adamc@915: (fn [nm :: Name] [t :: Type] meta => meta.New) adamc@915: [_] wholeRow M.raw; adamc@915: dml (insert M.tab (ensql row)); adamc@915: return row adamc@915: adamc@915: fun selector (r : $(M.key ++ M.row)) : sql_exp [T = M.key ++ M.row] [] [] bool = adamc@915: foldR2 [rawMeta] [id] adamc@915: [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool] adamc@915: (fn [nm :: Name] [t :: Type] [key :: {Type}] [[nm] ~ key] adamc@915: (meta : rawMeta t) (v : t) adamc@915: (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool) adamc@915: [rest :: {Type}] [rest ~ [nm = t] ++ key] => adamc@915: (WHERE T.{nm} = {@sql_inject meta.Inj v} AND {exp [[nm = t] ++ rest] !})) adamc@915: (fn [rest :: {Type}] [rest ~ []] => (WHERE TRUE)) adamc@915: [_] M.keyFolder (M.raw --- map rawMeta M.row) (r --- M.row) adamc@915: [_] ! adamc@915: adamc@915: fun save {Old = row, New = row'} = adamc@915: dml (update [M.key ++ M.row] ! adamc@915: (ensql row') adamc@915: M.tab adamc@915: (selector row)) adamc@915: adamc@915: fun delete row = adamc@915: dml (Basis.delete M.tab (selector row)) adamc@915: adamc@915: val cols = M.cols adamc@915: adamc@915: val folder = M.colsFolder adamc@915: end) adamc@915: end