Mercurial > urweb
view demo/more/dbgrid.ur @ 1739:c414850f206f
Add support for -boot flag, which allows in-tree execution of Ur/Web
The boot flag rewrites most hardcoded paths to point to the build
directory, and also forces static compilation. This is convenient
for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web.
The following changes were made:
* Header files were moved to include/urweb instead of include;
this lets FFI users point their C_INCLUDE_PATH at this directory
at write <urweb/urweb.h>. For internal Ur/Web executables,
we simply pass -I$PATH/include/urweb as normal.
* Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript
source files, while LIB is compiled products from libtool. For
in-tree compilation these live in different places.
* No longer reference Config for paths; instead use Settings; these
settings can be changed dynamically by Compiler.enableBoot ()
(TODO: add a disableBoot function.)
* config.h is now generated directly in include/urweb/config.h,
for consistency's sake (especially since it gets installed
along with the rest of the headers!)
* All of the autotools build products got updated.
* The linkStatic field in protocols now only contains the name of the
build product, and not the absolute path.
Future users have to be careful not to reference the Settings files
to early, lest they get an old version (this was the source of two
bugs during development of this patch.)
author | Edward Z. Yang <ezyang@mit.edu> |
---|---|
date | Wed, 02 May 2012 17:17:57 -0400 |
parents | 9253765d7724 |
children | 6bc2a8cb3a67 |
line wrap: on
line source
con rawMeta = fn t :: Type => {New : transaction t, Inj : sql_injectable t} con colMeta' = fn (row :: {Type}) (input :: Type) (filter :: Type) => {Header : string, Project : $row -> transaction input, Update : $row -> input -> transaction ($row), Display : input -> xbody, Edit : input -> xbody, Validate : input -> signal bool, CreateFilter : transaction filter, DisplayFilter : filter -> xbody, Filter : filter -> $row -> signal bool, Sort : option ($row -> $row -> bool)} con colMeta = fn (row :: {Type}) (global_input_filter :: (Type * Type * Type)) => {Initialize : transaction global_input_filter.1, Handlers : global_input_filter.1 -> colMeta' row global_input_filter.2 global_input_filter.3} con aggregateMeta = fn (row :: {Type}) (acc :: Type) => {Initial : acc, Step : $row -> acc -> acc, Display : acc -> xbody} structure Direct = struct con metaBase = fn actual_input_filter :: (Type * Type * Type) => {Display : actual_input_filter.2 -> xbody, Edit : actual_input_filter.2 -> xbody, Initialize : actual_input_filter.1 -> transaction actual_input_filter.2, Parse : actual_input_filter.2 -> signal (option actual_input_filter.1), CreateFilter : transaction actual_input_filter.3, DisplayFilter : actual_input_filter.3 -> xbody, Filter : actual_input_filter.3 -> actual_input_filter.1 -> signal bool, Sort : actual_input_filter.1 -> actual_input_filter.1 -> bool} datatype metaBoth actual input filter = NonNull of metaBase (actual, input, filter) * metaBase (option actual, input, filter) | Nullable of metaBase (actual, input, filter) con meta = fn global_actual_input_filter => {Initialize : transaction global_actual_input_filter.1, Handlers : global_actual_input_filter.1 -> metaBoth global_actual_input_filter.2 global_actual_input_filter.3 global_actual_input_filter.4} con editableState (ts :: (Type * Type * Type * Type)) = (ts.1, ts.3, ts.4) fun editable [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest) (editableState ts) = let fun doMr (mr : metaBase (ts.2, ts.3, ts.4)) : colMeta' ([nm = ts.2] ++ rest) ts.3 ts.4 = {Header = name, Project = fn r => mr.Initialize r.nm, Update = fn r s => vo <- current (mr.Parse s); return (case vo of None => r | Some v => r -- nm ++ {nm = v}), Display = mr.Display, Edit = mr.Edit, Validate = fn s => vo <- mr.Parse s; return (Option.isSome vo), CreateFilter = mr.CreateFilter, DisplayFilter = mr.DisplayFilter, Filter = fn i r => mr.Filter i r.nm, Sort = Some (fn r1 r2 => mr.Sort r1.nm r2.nm)} in {Initialize = m.Initialize, Handlers = fn data => case m.Handlers data of NonNull (mr, _) => doMr mr | Nullable mr => doMr mr} end con readOnlyState (ts :: (Type * Type * Type * Type)) = (ts.1, ts.3, ts.4) fun readOnly [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest) (readOnlyState ts) = let fun doMr mr = {Header = name, Project = fn r => mr.Initialize r.nm, Update = fn r _ => return r, Display = mr.Display, Edit = mr.Display, Validate = fn _ => return True, CreateFilter = mr.CreateFilter, DisplayFilter = mr.DisplayFilter, Filter = fn i r => mr.Filter i r.nm, Sort = Some (fn r1 r2 => mr.Sort r1.nm r2.nm)} in {Initialize = m.Initialize, Handlers = fn data => case m.Handlers data of NonNull (mr, _) => doMr mr | Nullable mr => doMr mr} end con metaBasic = fn actual_input_filter :: (Type * Type * Type) => {Display : actual_input_filter.2 -> xbody, Edit : source actual_input_filter.2 -> xbody, Initialize : actual_input_filter.1 -> actual_input_filter.2, InitializeNull : actual_input_filter.2, IsNull : actual_input_filter.2 -> bool, Parse : actual_input_filter.2 -> option actual_input_filter.1, CreateFilter : actual_input_filter.3, DisplayFilter : source actual_input_filter.3 -> xbody, Filter : actual_input_filter.3 -> actual_input_filter.1 -> bool, FilterIsNull : actual_input_filter.3 -> bool, Sort : actual_input_filter.1 -> actual_input_filter.1 -> bool} con basicState = source con basicFilter = source fun basic [ts ::: (Type * Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2, basicFilter ts.3) = {Initialize = return (), Handlers = fn () => NonNull ( {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>, Edit = m.Edit, Initialize = fn v => source (m.Initialize v), Parse = fn s => v <- signal s; return (m.Parse v), CreateFilter = source m.CreateFilter, DisplayFilter = m.DisplayFilter, Filter = fn f v => f <- signal f; return (if m.FilterIsNull f then True else m.Filter f v), Sort = m.Sort}, {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>, Edit = m.Edit, Initialize = fn v => source (case v of None => m.InitializeNull | Some v => m.Initialize v), Parse = fn s => v <- signal s; return (if m.IsNull v then Some None else case m.Parse v of None => None | Some v' => Some (Some v')), CreateFilter = source m.CreateFilter, DisplayFilter = m.DisplayFilter, Filter = fn f v => f <- signal f; return (if m.FilterIsNull f then True else case v of None => False | Some v => m.Filter f v), Sort = fn x y => case (x, y) of (None, _) => True | (Some x', Some y') => m.Sort x' y' | _ => False})} fun nullable [global] [actual] [input] [filter] (m : meta (global, actual, input, filter)) = {Initialize = m.Initialize, Handlers = fn d => case m.Handlers d of Nullable _ => error <xml>Don't stack calls to Direct.nullable!</xml> | NonNull (_, ho) => Nullable ho} type intGlobal = unit type intInput = basicState string type intFilter = basicFilter string val int : meta (intGlobal, int, intInput, intFilter) = basic {Display = fn s => <xml>{[s]}</xml>, Edit = fn s => <xml><ctextbox size={5} source={s}/></xml>, Initialize = fn n => show n, InitializeNull = "", IsNull = eq "", Parse = fn v => read v, CreateFilter = "", DisplayFilter = fn s => <xml><ctextbox size={5} source={s}/></xml> : xbody, Filter = fn s n => case read s of None => True | Some n' => n' = n, FilterIsNull = eq "", Sort = le} type stringGlobal = unit type stringInput = basicState string type stringFilter = basicFilter string val string : meta (stringGlobal, string, stringInput, stringFilter) = basic {Display = fn s => <xml>{[s]}</xml>, Edit = fn s => <xml><ctextbox source={s}/></xml>, Initialize = fn s => s, InitializeNull = "", IsNull = eq "", Parse = fn s => Some s, CreateFilter = "", DisplayFilter = fn s => <xml><ctextbox source={s}/></xml> : xbody, Filter = fn s n => case read s of None => True | Some n' => n' = n, FilterIsNull = eq "", Sort = le} type boolGlobal = unit type boolInput = basicState bool type boolFilter = basicFilter string val bool : meta (boolGlobal, bool, boolInput, boolFilter) = basic {Display = fn b => <xml>{[b]}</xml>, Edit = fn s => <xml><ccheckbox source={s}/></xml>, Initialize = fn b => b, InitializeNull = False, IsNull = fn _ => False, Parse = fn b => Some b, CreateFilter = "", DisplayFilter = fn s => <xml><cselect source={s}> <coption/> <coption value="0">False</coption> <coption value="1">True</coption> </cselect></xml> : xbody, Filter = fn s b => case s of "0" => b = False | "1" => b = True | _ => True, FilterIsNull = eq "", Sort = le} functor Foreign (M : sig con row :: {Type} con t :: Type val show_t : show t val read_t : read t val eq_t : eq t val ord_t : ord t val inj_t : sql_injectable t con nm :: Name constraint [nm] ~ row table tab : ([nm = t] ++ row) val render : $([nm = t] ++ row) -> string end) = struct open M type global = list (t * string) type input = source string * option (t * $row) type filter = source string val getChoices = List.mapQuery (SELECT * FROM tab AS T) (fn r => (r.T.nm, render r.T)) fun getChoice k = r <- oneRow (SELECT T.{{row}} FROM tab AS T WHERE T.{nm} = {[k]}); return r.T val meta : meta (global, M.t, input, filter) = {Initialize = getChoices, Handlers = fn choices => NonNull ( {Display = fn (_, kr) => case kr of None => error <xml>Unexpected Foreign null</xml> | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>, Edit = fn (s, kr) => <xml><cselect source={s}> {List.mapX (fn (k', rend) => <xml><coption value={show k'} selected={case kr of None => False | Some (k, _) => k' = k}>{[rend]}</coption> </xml>) choices} </cselect></xml>, Initialize = fn k => s <- source (show k); r <- rpc (getChoice k); return (s, Some (k, r)), Parse = fn (s, _) => k <- signal s; return (read k : option t), CreateFilter = source "", DisplayFilter = fn s => <xml><cselect source={s}> <coption/> {List.mapX (fn (k, rend) => <xml><coption value={show k}>{[rend]}</coption></xml>) choices} </cselect></xml> : xbody, Filter = fn s k => s <- signal s; return (case read s : option t of None => True | Some k' => k' = k), Sort = le}, {Display = fn (_, kr) => case kr of None => <xml>NULL</xml> | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>, Edit = fn (s, kr) => <xml><cselect source={s}> <coption value="" selected={case kr of None => True | _ => False}>NULL</coption> {List.mapX (fn (k', rend) => <xml><coption value={show k'} selected={case kr of None => False | Some (k, _) => k' = k}>{[rend]}</coption> </xml>) choices} </cselect></xml>, Initialize = fn k => case k of None => s <- source ""; return (s, None) | Some k => s <- source (show k); r <- rpc (getChoice k); return (s, Some (k, r)), Parse = fn (s, _) => ks <- signal s; return (case ks of "" => Some None | _ => case read ks : option t of None => None | Some k => Some (Some k)), CreateFilter = source "", DisplayFilter = fn s => <xml><cselect source={s}> <coption/> <coption value="0">NULL</coption> {List.mapX (fn (k, rend) => <xml><coption value={"1" ^ show k}>{[rend]}</coption> </xml>) choices} </cselect></xml> : xbody, Filter = fn s ko => s <- signal s; return (case s of "" => True | "0" => ko = None | _ => case read (String.substring s {Start = 1, Len = String.length s - 1}) : option t of None => True | Some k => ko = Some k), Sort = le})} end end con computedState = (unit, xbody, unit) fun computed [row] [t] (_ : show t) name (f : $row -> t) : colMeta row computedState = {Initialize = return (), Handlers = fn () => {Header = name, Project = fn r => return <xml>{[f r]}</xml>, Update = fn r _ => return r, Display = fn x => x, Edit = fn _ => <xml>...</xml>, Validate = fn _ => return True, CreateFilter = return (), DisplayFilter = fn _ => <xml/>, Filter = fn _ _ => return True, Sort = None}} fun computedHtml [row] name (f : $row -> xbody) : colMeta row computedState = {Initialize = return (), Handlers = fn () => {Header = name, Project = fn r => return (f r), Update = fn r _ => return r, Display = fn x => x, Edit = fn _ => <xml>...</xml>, Validate = fn _ => return True, CreateFilter = return (), DisplayFilter = fn _ => <xml/>, Filter = fn _ _ => return True, Sort = None}} functor Make(M : sig con key :: {Type} con row :: {Type} constraint key ~ row table tab : (key ++ row) val raw : $(map rawMeta (key ++ row)) con cols :: {(Type * Type * Type)} val cols : $(map (colMeta (key ++ row)) cols) val keyFolder : folder key val rowFolder : folder row val colsFolder : folder cols con aggregates :: {Type} val aggregates : $(map (aggregateMeta (key ++ row)) aggregates) val aggFolder : folder aggregates val pageLength : option int end) = struct open Grid.Make(struct fun keyOf r = r --- M.row val list = query (SELECT * FROM {{M.tab}} AS T) (fn r rs => return (r.T :: rs)) [] val wholeRow = @Folder.concat ! M.keyFolder M.rowFolder fun ensql [env] (r : $(M.key ++ M.row)) = @map2 [rawMeta] [ident] [sql_exp env [] []] (fn [t] meta v => @sql_inject meta.Inj v) wholeRow M.raw r val new = row <- @Monad.mapR _ [rawMeta] [ident] (fn [nm :: Name] [t :: Type] meta => meta.New) wholeRow M.raw; dml (insert M.tab (ensql row)); return row fun selector (r : $M.key) : sql_exp [T = M.key ++ M.row] [] [] bool = @foldR2 [rawMeta] [ident] [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool] (fn [nm :: Name] [t :: Type] [key :: {Type}] [[nm] ~ key] (meta : rawMeta t) (v : t) (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool) [rest :: {Type}] [rest ~ [nm = t] ++ key] => (WHERE T.{nm} = {@sql_inject meta.Inj v} AND {exp [[nm = t] ++ rest]})) (fn [rest :: {Type}] [rest ~ []] => (WHERE TRUE)) M.keyFolder (M.raw --- map rawMeta M.row) r [_] ! fun save key row = dml (update [M.key ++ M.row] (ensql row) M.tab (selector key)) fun delete key = dml (Basis.delete M.tab (selector key)) val cols = M.cols val folder = M.colsFolder val aggregates = M.aggregates val aggFolder = M.aggFolder val pageLength = M.pageLength end) end