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