adamc@915: con rawMeta = fn t :: Type => adamc@915: {New : transaction t, adamc@915: Inj : sql_injectable t} adamc@915: adamc@944: con colMeta' = fn (row :: {Type}) (input :: Type) (filter :: Type) => adamc@915: {Header : string, adamc@944: Project : $row -> transaction input, adamc@944: Update : $row -> input -> transaction ($row), adamc@944: Display : input -> xbody, adamc@944: Edit : input -> xbody, adamc@944: Validate : input -> signal bool, adamc@944: CreateFilter : transaction filter, adamc@944: DisplayFilter : filter -> xbody, adamc@944: Filter : filter -> $row -> signal bool} adamc@915: adamc@944: con colMeta = fn (row :: {Type}) (global_input_filter :: (Type * Type * Type)) => adamc@944: {Initialize : transaction global_input_filter.1, adamc@944: Handlers : global_input_filter.1 -> colMeta' row global_input_filter.2 global_input_filter.3} adamc@915: adamc@935: con aggregateMeta = fn (row :: {Type}) (acc :: Type) => adamc@935: {Initial : acc, adamc@935: Step : $row -> acc -> acc, adamc@935: Display : acc -> xbody} adamc@935: adamc@915: structure Direct = struct adamc@944: con metaBase = fn actual_input_filter :: (Type * Type * Type) => adamc@944: {Display : actual_input_filter.2 -> xbody, adamc@944: Edit : actual_input_filter.2 -> xbody, adamc@944: Initialize : actual_input_filter.1 -> transaction actual_input_filter.2, adamc@944: Parse : actual_input_filter.2 -> signal (option actual_input_filter.1), adamc@944: CreateFilter : transaction actual_input_filter.3, adamc@944: DisplayFilter : actual_input_filter.3 -> xbody, adamc@944: Filter : actual_input_filter.3 -> actual_input_filter.1 -> signal bool} adamc@930: adamc@944: datatype metaBoth actual input filter = adamc@944: NonNull of metaBase (actual, input, filter) * metaBase (option actual, input, filter) adamc@944: | Nullable of metaBase (actual, input, filter) adamc@930: adamc@944: con meta = fn global_actual_input_filter :: (Type * Type * Type * Type) => adamc@944: {Initialize : transaction global_actual_input_filter.1, adamc@944: Handlers : global_actual_input_filter.1 adamc@944: -> metaBoth global_actual_input_filter.2 global_actual_input_filter.3 adamc@944: global_actual_input_filter.4} adamc@915: adamc@944: con editableState (ts :: (Type * Type * Type * Type)) = (ts.1, ts.3, ts.4) 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@944: Validate = fn s => vo <- mr.Parse s; return (Option.isSome vo), adamc@944: CreateFilter = mr.CreateFilter, adamc@944: DisplayFilter = mr.DisplayFilter, adamc@944: Filter = fn i r => mr.Filter i r.nm} 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@944: con readOnlyState (ts :: (Type * Type * Type * Type)) = (ts.1, ts.3, ts.4) 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@944: Validate = fn _ => return True, adamc@944: CreateFilter = mr.CreateFilter, adamc@944: DisplayFilter = mr.DisplayFilter, adamc@944: Filter = fn i r => mr.Filter i r.nm} 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@944: con metaBasic = fn actual_input_filter :: (Type * Type * Type) => adamc@944: {Display : actual_input_filter.2 -> xbody, adamc@944: Edit : source actual_input_filter.2 -> xbody, adamc@944: Initialize : actual_input_filter.1 -> actual_input_filter.2, adamc@944: InitializeNull : actual_input_filter.2, adamc@944: IsNull : actual_input_filter.2 -> bool, adamc@944: Parse : actual_input_filter.2 -> option actual_input_filter.1, adamc@944: CreateFilter : actual_input_filter.3, adamc@944: DisplayFilter : source actual_input_filter.3 -> xbody, adamc@944: Filter : actual_input_filter.3 -> actual_input_filter.1 -> bool, adamc@944: FilterIsNull : actual_input_filter.3 -> bool} adamc@915: adamc@915: con basicState = source adamc@944: con basicFilter = source adamc@944: fun basic [ts ::: (Type * Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2, basicFilter ts.3) = 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@944: Parse = fn s => v <- signal s; return (m.Parse v), adamc@944: CreateFilter = source m.CreateFilter, adamc@944: DisplayFilter = m.DisplayFilter, adamc@944: Filter = fn f v => f <- signal f; return (m.Filter f 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@944: | Some v' => Some (Some v')), adamc@944: CreateFilter = source m.CreateFilter, adamc@944: DisplayFilter = m.DisplayFilter, adamc@944: Filter = fn f v => f <- signal f; adamc@944: return (if m.FilterIsNull f then adamc@944: Option.isNone v adamc@944: else adamc@944: case v of adamc@944: None => False adamc@944: | Some v => m.Filter f v) : signal bool})} adamc@930: adamc@944: fun nullable [global] [actual] [input] [filter] (m : meta (global, actual, input, filter)) = 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@944: type intFilter = basicFilter string adamc@944: val int : meta (intGlobal, int, intInput, intFilter) = 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@944: Parse = fn v => read v, adamc@944: CreateFilter = "", adamc@944: DisplayFilter = fn s => : xbody, adamc@944: Filter = fn s n => adamc@944: case read s of adamc@944: None => True adamc@944: | Some n' => n' = n, adamc@944: FilterIsNull = eq ""} adamc@915: adamc@915: type stringGlobal = unit adamc@915: type stringInput = basicState string adamc@944: type stringFilter = basicFilter string adamc@944: val string : meta (stringGlobal, string, stringInput, stringFilter) = 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@944: Parse = fn s => Some s, adamc@944: CreateFilter = "", adamc@944: DisplayFilter = fn s => : xbody, adamc@944: Filter = fn s n => adamc@944: case read s of adamc@944: None => True adamc@944: | Some n' => n' = n, adamc@944: FilterIsNull = eq ""} adamc@915: adamc@915: type boolGlobal = unit adamc@915: type boolInput = basicState bool adamc@944: type boolFilter = basicFilter string adamc@944: val bool : meta (boolGlobal, bool, boolInput, boolFilter) = 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@944: Parse = fn b => Some b, adamc@944: CreateFilter = "", adamc@944: DisplayFilter = fn s => adamc@944: adamc@944: False adamc@944: True adamc@944: : xbody, adamc@944: Filter = fn s b => adamc@944: case s of adamc@944: "0" => b = False adamc@944: | "1" => b = True adamc@944: | _ => True, adamc@944: FilterIsNull = eq ""} 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@944: type global = list (t * string) adamc@944: type input = source string * option (t * $row) adamc@944: type filter = source string 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@944: val meta : meta (global, M.t, input, filter) = 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@944: Parse = fn (s, _) => k <- signal s; return (read k : option t), adamc@944: CreateFilter = source "", adamc@944: DisplayFilter = fn s => adamc@944: adamc@944: adamc@944: {List.mapX (fn (k, rend) => adamc@944: {[rend]}) adamc@944: choices} adamc@944: : xbody, adamc@944: Filter = fn s k => s <- signal s; adamc@944: return (case read s : option t of adamc@944: None => True adamc@944: | Some k' => k' = k)}, 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@944: | Some k => Some (Some k)), adamc@944: CreateFilter = source "", adamc@944: DisplayFilter = fn s => adamc@944: adamc@944: adamc@944: NULL adamc@944: {List.mapX (fn (k, rend) => adamc@944: {[rend]} adamc@944: ) adamc@944: choices} adamc@944: : xbody, adamc@944: Filter = fn s ko => s <- signal s; adamc@944: return (case s of adamc@944: "" => True adamc@944: | "0" => ko = None adamc@944: | _ => adamc@944: case read (String.substring s {Start = 1, adamc@944: Len = String.length s - 1}) adamc@944: : option t of adamc@944: None => True adamc@944: | Some k => ko = Some k)})} adamc@915: end adamc@915: end adamc@915: adamc@944: con computedState = (unit, xbody, unit) 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@944: Validate = fn _ => return True, adamc@944: CreateFilter = return (), adamc@944: DisplayFilter = fn _ => , adamc@944: Filter = 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@944: Validate = fn _ => return True, adamc@944: CreateFilter = return (), adamc@944: DisplayFilter = fn _ => , adamc@944: Filter = 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@944: con cols :: {(Type * 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@935: adamc@935: con aggregates :: {Type} adamc@935: val aggregates : $(map (aggregateMeta (key ++ row)) aggregates) adamc@937: val aggFolder : folder aggregates adamc@915: end) = struct adamc@915: open Grid.Make(struct adamc@936: fun keyOf r = r --- M.row adamc@936: 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@936: fun selector (r : $M.key) : 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@936: [_] M.keyFolder (M.raw --- map rawMeta M.row) r adamc@915: [_] ! adamc@915: adamc@936: fun save key row = adamc@915: dml (update [M.key ++ M.row] ! adamc@936: (ensql row) adamc@915: M.tab adamc@936: (selector key)) adamc@915: adamc@936: fun delete key = adamc@936: dml (Basis.delete M.tab (selector key)) adamc@915: adamc@915: val cols = M.cols adamc@915: adamc@915: val folder = M.colsFolder adamc@935: adamc@935: val aggregates = M.aggregates adamc@937: adamc@937: val aggFolder = M.aggFolder adamc@915: end) adamc@915: end