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@961: Filter : filter -> $row -> signal bool, adamc@961: Sort : option ($row -> $row -> 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@961: Filter : actual_input_filter.3 -> actual_input_filter.1 -> signal bool, adamc@961: Sort : actual_input_filter.1 -> actual_input_filter.1 -> 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: adam@1304: con meta = fn global_actual_input_filter => 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 adam@1304: fun doMr (mr : metaBase (ts.2, ts.3, ts.4)) : colMeta' ([nm = ts.2] ++ rest) ts.3 ts.4 = adam@1304: {Header = name, adam@1304: Project = fn r => mr.Initialize r.nm, adam@1304: Update = fn r s => adam@1304: vo <- current (mr.Parse s); adam@1304: return (case vo of adam@1304: None => r adam@1304: | Some v => r -- nm ++ {nm = v}), adam@1304: Display = mr.Display, adam@1304: Edit = mr.Edit, adam@1304: Validate = fn s => vo <- mr.Parse s; return (Option.isSome vo), adam@1304: CreateFilter = mr.CreateFilter, adam@1304: DisplayFilter = mr.DisplayFilter, adam@1304: Filter = fn i r => mr.Filter i r.nm, adam@1304: Sort = Some (fn r1 r2 => mr.Sort r1.nm r2.nm)} adamc@930: in adamc@930: {Initialize = m.Initialize, adamc@930: Handlers = fn data => case m.Handlers data of adam@1304: NonNull (mr, _) => doMr mr adam@1304: | 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@961: Filter = fn i r => mr.Filter i r.nm, adamc@961: Sort = Some (fn r1 r2 => mr.Sort r1.nm r2.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@961: FilterIsNull : actual_input_filter.3 -> bool, adamc@961: Sort : actual_input_filter.1 -> actual_input_filter.1 -> 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@946: Filter = fn f v => f <- signal f; adamc@946: return (if m.FilterIsNull f then adamc@946: True adamc@946: else adamc@961: m.Filter f v), adamc@961: Sort = m.Sort}, 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@946: True adamc@944: else adamc@944: case v of adamc@944: None => False adamc@961: | Some v => m.Filter f v), adamc@961: Sort = fn x y => adamc@961: case (x, y) of adamc@961: (None, _) => True adamc@961: | (Some x', Some y') => m.Sort x' y' adamc@961: | _ => False})} 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@946: 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@946: 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@961: FilterIsNull = eq "", adamc@961: Sort = le} 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@961: FilterIsNull = eq "", adamc@961: Sort = le} 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@961: FilterIsNull = eq "", adamc@961: Sort = le} 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@961: val ord_t : ord 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@961: | Some k' => k' = k), adamc@961: Sort = le}, 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@961: | Some k => ko = Some k), adamc@961: Sort = le})} 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@961: Filter = fn _ _ => return True, adamc@961: Sort = None}} 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@961: Filter = fn _ _ => return True, adamc@961: Sort = None}} 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@964: adamc@964: val pageLength : option int 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@1093: @map2 [rawMeta] [id] [sql_exp env [] []] adamc@1093: (fn [t] meta v => @sql_inject meta.Inj v) adamc@1093: wholeRow M.raw r adamc@915: adamc@915: val new = adamc@1093: row <- @Monad.mapR _ [rawMeta] [id] adamc@1093: (fn [nm :: Name] [t :: Type] meta => meta.New) adamc@1093: 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@1093: @foldR2 [rawMeta] [id] adamc@1093: [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool] adamc@1093: (fn [nm :: Name] [t :: Type] [key :: {Type}] [[nm] ~ key] adamc@1093: (meta : rawMeta t) (v : t) adamc@1093: (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool) adamc@1093: [rest :: {Type}] [rest ~ [nm = t] ++ key] => adam@1488: (WHERE T.{nm} = {@sql_inject meta.Inj v} AND {exp [[nm = t] ++ rest]})) adamc@1093: (fn [rest :: {Type}] [rest ~ []] => (WHERE TRUE)) adamc@1093: M.keyFolder (M.raw --- map rawMeta M.row) r adamc@1093: [_] ! adamc@915: adamc@936: fun save key row = adamc@1093: 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@964: adamc@964: val pageLength = M.pageLength adamc@915: end) adamc@915: end