Mercurial > urweb
changeset 961:8c37699de273
Grid sorting working
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 19 Sep 2009 13:32:33 -0400 |
| parents | 6f34950825b6 |
| children | 7e7edfb6fe82 |
| files | demo/more/dbgrid.ur demo/more/dbgrid.urs demo/more/grid.ur demo/more/grid.urs lib/js/urweb.js lib/ur/basis.urs lib/ur/option.ur lib/ur/option.urs src/jscomp.sml src/monoize.sml |
| diffstat | 10 files changed, 88 insertions(+), 21 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/more/dbgrid.ur Sat Sep 19 10:56:09 2009 -0400 +++ b/demo/more/dbgrid.ur Sat Sep 19 13:32:33 2009 -0400 @@ -11,7 +11,8 @@ Validate : input -> signal bool, CreateFilter : transaction filter, DisplayFilter : filter -> xbody, - Filter : filter -> $row -> signal bool} + 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, @@ -30,7 +31,8 @@ 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} + 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) @@ -58,7 +60,8 @@ 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} + 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 @@ -78,7 +81,8 @@ Validate = fn _ => return True, CreateFilter = mr.CreateFilter, DisplayFilter = mr.DisplayFilter, - Filter = fn i r => mr.Filter i r.nm} + 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 @@ -96,7 +100,8 @@ 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} + FilterIsNull : actual_input_filter.3 -> bool, + Sort : actual_input_filter.1 -> actual_input_filter.1 -> bool} con basicState = source con basicFilter = source @@ -113,7 +118,8 @@ return (if m.FilterIsNull f then True else - m.Filter f v)}, + 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 @@ -134,7 +140,12 @@ else case v of None => False - | Some v => m.Filter f v) : signal bool})} + | 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, @@ -158,7 +169,8 @@ case read s of None => True | Some n' => n' = n, - FilterIsNull = eq ""} + FilterIsNull = eq "", + Sort = le} type stringGlobal = unit type stringInput = basicState string @@ -176,7 +188,8 @@ case read s of None => True | Some n' => n' = n, - FilterIsNull = eq ""} + FilterIsNull = eq "", + Sort = le} type boolGlobal = unit type boolInput = basicState bool @@ -199,7 +212,8 @@ "0" => b = False | "1" => b = True | _ => True, - FilterIsNull = eq ""} + FilterIsNull = eq "", + Sort = le} functor Foreign (M : sig con row :: {Type} @@ -207,6 +221,7 @@ 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 @@ -258,7 +273,8 @@ Filter = fn s k => s <- signal s; return (case read s : option t of None => True - | Some k' => k' = k)}, + | 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>, @@ -308,7 +324,8 @@ Len = String.length s - 1}) : option t of None => True - | Some k => ko = Some k)})} + | Some k => ko = Some k), + Sort = le})} end end @@ -323,7 +340,8 @@ Validate = fn _ => return True, CreateFilter = return (), DisplayFilter = fn _ => <xml/>, - Filter = fn _ _ => return True}} + Filter = fn _ _ => return True, + Sort = None}} fun computedHtml [row] name (f : $row -> xbody) : colMeta row computedState = {Initialize = return (), Handlers = fn () => {Header = name, @@ -334,7 +352,8 @@ Validate = fn _ => return True, CreateFilter = return (), DisplayFilter = fn _ => <xml/>, - Filter = fn _ _ => return True}} + Filter = fn _ _ => return True, + Sort = None}} functor Make(M : sig con key :: {Type}
--- a/demo/more/dbgrid.urs Sat Sep 19 10:56:09 2009 -0400 +++ b/demo/more/dbgrid.urs Sat Sep 19 13:32:33 2009 -0400 @@ -11,7 +11,8 @@ Validate : input -> signal bool, CreateFilter : transaction filter, DisplayFilter : filter -> xbody, - Filter : filter -> $row -> signal bool} + 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, @@ -30,7 +31,8 @@ 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} + 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) @@ -79,6 +81,7 @@ 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
--- a/demo/more/grid.ur Sat Sep 19 10:56:09 2009 -0400 +++ b/demo/more/grid.ur Sat Sep 19 13:32:33 2009 -0400 @@ -7,7 +7,8 @@ Validate : input -> signal bool, CreateFilter : transaction filter, DisplayFilter : filter -> xbody, - Filter : filter -> row -> signal bool} + 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, @@ -101,14 +102,19 @@ rs <- List.mapM (newRow cols) init; Dlist.replace rows rs - fun render grid = <xml> + fun render (grid : grid) = <xml> <table class={tabl}> <tr class={tr}> - <th/> <th/> <th/> + <th/> <th/> <th><button value="No sort" onclick={set grid.Sort None}/></th> {foldRX2 [fst3] [colMeta M.row] [_] (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}] [[nm] ~ rest] data (meta : colMeta M.row p) => - <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>) + <xml><th class={th}> + {case (meta.Handlers data).Sort of + None => txt (meta.Handlers data).Header + | sort => <xml><button value={(meta.Handlers data).Header} + onclick={set grid.Sort sort}/></xml>} + </th></xml>) [_] M.folder grid.Cols M.cols} </tr>
--- a/demo/more/grid.urs Sat Sep 19 10:56:09 2009 -0400 +++ b/demo/more/grid.urs Sat Sep 19 13:32:33 2009 -0400 @@ -7,7 +7,8 @@ Validate : input -> signal bool, CreateFilter : transaction filter, DisplayFilter : filter -> xbody, - Filter : filter -> row -> signal bool} + 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,
--- a/lib/js/urweb.js Sat Sep 19 10:56:09 2009 -0400 +++ b/lib/js/urweb.js Sat Sep 19 13:32:33 2009 -0400 @@ -506,6 +506,9 @@ throw ("Can't unmarshal list (" + tok + ")"); } +function strcmp(str1, str2) { + return ((str1 == str2) ? 0 : ((str1 > str2) ? 1 : -1)); +} // Remote calls
--- a/lib/ur/basis.urs Sat Sep 19 10:56:09 2009 -0400 +++ b/lib/ur/basis.urs Sat Sep 19 13:32:33 2009 -0400 @@ -49,6 +49,7 @@ val ord_char : ord char val ord_bool : ord bool val ord_time : ord time +val mkOrd : t ::: Type -> {Lt : t -> t -> bool, Le : t -> t -> bool} -> ord t (** String operations *)
--- a/lib/ur/option.ur Sat Sep 19 10:56:09 2009 -0400 +++ b/lib/ur/option.ur Sat Sep 19 13:32:33 2009 -0400 @@ -7,6 +7,18 @@ | (Some x, Some y) => x = y | _ => False) +fun ord [a] (_ : ord a) = + mkOrd {Lt = fn x y => + case (x, y) of + (None, Some _) => True + | (Some x, Some y) => x < y + | _ => False, + Le = fn x y => + case (x, y) of + (None, _) => True + | (Some x, Some y) => x <= y + | _ => False} + fun isNone [a] x = case x of None => True
--- a/lib/ur/option.urs Sat Sep 19 10:56:09 2009 -0400 +++ b/lib/ur/option.urs Sat Sep 19 13:32:33 2009 -0400 @@ -1,6 +1,7 @@ datatype t = datatype Basis.option val eq : a ::: Type -> eq a -> eq (t a) +val ord : a ::: Type -> ord a -> ord (t a) val isNone : a ::: Type -> t a -> bool val isSome : a ::: Type -> t a -> bool
--- a/src/jscomp.sml Sat Sep 19 10:56:09 2009 -0400 +++ b/src/jscomp.sml Sat Sep 19 13:32:33 2009 -0400 @@ -874,6 +874,18 @@ str ")"], st) end + | EBinop ("strcmp", e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "strcmp(", + e1, + str ",", + e2, + str ")"], + st) + end | EBinop (s, e1, e2) => let val s =
--- a/src/monoize.sml Sat Sep 19 10:56:09 2009 -0400 +++ b/src/monoize.sml Sat Sep 19 13:32:33 2009 -0400 @@ -1024,6 +1024,15 @@ boolBin "<", boolBin "<=") end + | L.ECApp ((L.EFfi ("Basis", "mkOrd"), _), t) => + let + val t = monoType env t + val b = (L'.TFfi ("Basis", "bool"), loc) + val dom = ordTy t + in + ((L'.EAbs ("f", dom, dom, + (L'.ERel 0, loc)), loc), fm) + end | L.ECApp ((L.EFfi ("Basis", "show"), _), t) => let