summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--demo/more/dbgrid.ur47
-rw-r--r--demo/more/dbgrid.urs7
-rw-r--r--demo/more/grid.ur14
-rw-r--r--demo/more/grid.urs3
-rw-r--r--lib/js/urweb.js3
-rw-r--r--lib/ur/basis.urs1
-rw-r--r--lib/ur/option.ur12
-rw-r--r--lib/ur/option.urs1
-rw-r--r--src/jscomp.sml12
-rw-r--r--src/monoize.sml9
10 files changed, 88 insertions, 21 deletions
diff --git a/demo/more/dbgrid.ur b/demo/more/dbgrid.ur
index eb30a990..a935e900 100644
--- a/demo/more/dbgrid.ur
+++ b/demo/more/dbgrid.ur
@@ -11,7 +11,8 @@ con colMeta' = fn (row :: {Type}) (input :: Type) (filter :: Type) =>
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
"0" => b = False
| "1" => b = True
| _ => True,
- FilterIsNull = eq ""}
+ FilterIsNull = eq "",
+ Sort = le}
functor Foreign (M : sig
con row :: {Type}
@@ -207,6 +221,7 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ structure Direct = struct
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 @@ fun computed [row] [t] (_ : show t) name (f : $row -> t) : colMeta row computedS
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 @@ fun computedHtml [row] name (f : $row -> xbody) : colMeta row computedState =
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}
diff --git a/demo/more/dbgrid.urs b/demo/more/dbgrid.urs
index 58c5197a..f241c334 100644
--- a/demo/more/dbgrid.urs
+++ b/demo/more/dbgrid.urs
@@ -11,7 +11,8 @@ con colMeta' = fn (row :: {Type}) (input :: Type) (filter :: Type) =>
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 @@ structure Direct : sig
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 @@ structure Direct : sig
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
diff --git a/demo/more/grid.ur b/demo/more/grid.ur
index 829fead0..7cd16d72 100644
--- a/demo/more/grid.ur
+++ b/demo/more/grid.ur
@@ -7,7 +7,8 @@ con colMeta' = fn (row :: Type) (input :: Type) (filter :: Type) =>
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 @@ functor Make(M : sig
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>
diff --git a/demo/more/grid.urs b/demo/more/grid.urs
index 2ab9fbcc..30cd9bc6 100644
--- a/demo/more/grid.urs
+++ b/demo/more/grid.urs
@@ -7,7 +7,8 @@ con colMeta' = fn (row :: Type) (input :: Type) (filter :: Type) =>
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,
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index b1046aa6..638bb2b9 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -506,6 +506,9 @@ function uul(getToken, getData) {
throw ("Can't unmarshal list (" + tok + ")");
}
+function strcmp(str1, str2) {
+ return ((str1 == str2) ? 0 : ((str1 > str2) ? 1 : -1));
+}
// Remote calls
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 04404ad5..b7468d2f 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -49,6 +49,7 @@ val ord_string : ord string
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 *)
diff --git a/lib/ur/option.ur b/lib/ur/option.ur
index a22cf5b5..1ba33d8e 100644
--- a/lib/ur/option.ur
+++ b/lib/ur/option.ur
@@ -7,6 +7,18 @@ fun eq [a] (_ : eq a) =
| (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
diff --git a/lib/ur/option.urs b/lib/ur/option.urs
index f4570768..60ca6db9 100644
--- a/lib/ur/option.urs
+++ b/lib/ur/option.urs
@@ -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
diff --git a/src/jscomp.sml b/src/jscomp.sml
index dd375168..30f578c4 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -874,6 +874,18 @@ fun process file =
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 =
diff --git a/src/monoize.sml b/src/monoize.sml
index 865acff4..00230d1a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1024,6 +1024,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-17 11:35:47 +0000