summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/js/urweb.js21
-rw-r--r--lib/ur/basis.urs20
-rw-r--r--lib/ur/json.ur387
-rw-r--r--lib/ur/json.urs31
-rw-r--r--lib/ur/top.ur7
-rw-r--r--lib/ur/top.urs4
6 files changed, 453 insertions, 17 deletions
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 68e7979d..222a8322 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -731,6 +731,8 @@ function flattenLocal(s) {
// Dynamic tree management
function populate(node) {
+ if (node.dead) return;
+
var s = node.signal;
var oldSources = node.sources;
try {
@@ -760,8 +762,7 @@ function sv(s, v) {
s.data = v;
for (var ls = s.dyns; ls; ls = ls.next)
- if (!ls.dead)
- populate(ls.data);
+ populate(ls.data);
}
}
function sg(s) {
@@ -1099,12 +1100,18 @@ function active(s) {
function input(x, s, recreate, type, name) {
if (name) x.name = name;
if (type) x.type = type;
- x.dead = false;
- x.signal = ss(s);
- x.sources = null;
- x.recreate = recreate(x);
addNode(x);
- populate(x);
+
+ var sc = document.createElement("script");
+ sc.dead = false;
+ sc.signal = ss(s);
+ sc.sources = null;
+ sc.recreate = recreate(x);
+
+ if (x.parentNode)
+ x.parentNode.insertBefore(sc, x);
+
+ populate(sc);
return x;
}
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 1163daed..8b0d4faa 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -1075,23 +1075,23 @@ val curl : ctext
val ctel : ctext
val ccolor : ctext
-val cnumber : cformTag ([Source = source float, Value = float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val crange : cformTag ([Source = source float, Value = float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cdate : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cdatetime : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cdatetime_local : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cmonth : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val cweek : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
-val ctime : cformTag ([Source = source string, Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cnumber : cformTag ([Source = source float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val crange : cformTag ([Source = source float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cmonth : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val cweek : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val ctime : cformTag ([Source = source string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val button : cformTag ([Value = string] ++ boxAttrs) []
-val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
+val ccheckbox : cformTag ([Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) []
val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) [Cselect]
val coption : unit -> tag [Value = string, Selected = bool] [Cselect, Body] [] [] []
-val ctextarea : cformTag ([Value = string, Rows = int, Cols = int, Source = source string, Onchange = transaction unit,
+val ctextarea : cformTag ([Rows = int, Cols = int, Source = source string, Onchange = transaction unit,
Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) []
(*** Tables *)
diff --git a/lib/ur/json.ur b/lib/ur/json.ur
new file mode 100644
index 00000000..9288a6dd
--- /dev/null
+++ b/lib/ur/json.ur
@@ -0,0 +1,387 @@
+con json a = {ToJson : a -> string,
+ FromJson : string -> a * string}
+
+fun mkJson [a] (x : {ToJson : a -> string,
+ FromJson : string -> a * string}) = x
+
+fun skipSpaces s =
+ let
+ val len = String.length s
+
+ fun skip i =
+ if i >= len then
+ ""
+ else
+ let
+ val ch = String.sub s i
+ in
+ if Char.isSpace ch then
+ skip (i+1)
+ else
+ String.substring s {Start = i, Len = len-i}
+ end
+ in
+ skip 0
+ end
+
+fun toJson [a] (j : json a) : a -> string = j.ToJson
+fun fromJson' [a] (j : json a) : string -> a * string = j.FromJson
+
+fun fromJson [a] (j : json a) (s : string) : a =
+ let
+ val (v, s') = j.FromJson (skipSpaces s)
+ in
+ if String.all Char.isSpace s' then
+ v
+ else
+ error <xml>Extra content at end of JSON record: {[s']}</xml>
+ end
+
+fun escape s =
+ let
+ fun esc s =
+ case s of
+ "" => "\""
+ | _ =>
+ let
+ val ch = String.sub s 0
+ in
+ (if ch = #"\"" || ch = #"\\" then
+ "\\" ^ String.str ch
+ else
+ String.str ch) ^ esc (String.suffix s 1)
+ end
+ in
+ "\"" ^ esc s
+ end
+
+fun unescape s =
+ let
+ val len = String.length s
+
+ fun findEnd i =
+ if i >= len then
+ error <xml>JSON unescape: string ends before quote: {[s]}</xml>
+ else
+ let
+ val ch = String.sub s i
+ in
+ case ch of
+ #"\"" => i
+ | #"\\" =>
+ if i+1 >= len then
+ error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else
+ findEnd (i+2)
+ | _ => findEnd (i+1)
+ end
+
+ val last = findEnd 1
+
+ fun unesc i =
+ if i >= last then
+ ""
+ else
+ let
+ val ch = String.sub s i
+ in
+ case ch of
+ #"\\" =>
+ if i+1 >= len then
+ error <xml>JSON unescape: Bad escape sequence: {[s]}</xml>
+ else
+ String.str (String.sub s (i+1)) ^ unesc (i+2)
+ | _ => String.str ch ^ unesc (i+1)
+ end
+ in
+ if len = 0 || String.sub s 0 <> #"\"" then
+ error <xml>JSON unescape: String doesn't start with double quote: {[s]}</xml>
+ else
+ (unesc 1, String.substring s {Start = last+1, Len = len-last-1})
+ end
+
+val json_string = {ToJson = escape,
+ FromJson = unescape}
+
+fun numIn [a] (_ : read a) s : a * string =
+ let
+ val len = String.length s
+
+ fun findEnd i =
+ if i >= len then
+ i
+ else
+ let
+ val ch = String.sub s i
+ in
+ if Char.isDigit ch || ch = #"-" || ch = #"." || ch = #"E" || ch = #"e" then
+ findEnd (i+1)
+ else
+ i
+ end
+
+ val last = findEnd 0
+ in
+ (readError (String.substring s {Start = 0, Len = last}), String.substring s {Start = last, Len = len-last})
+ end
+
+fun json_num [a] (_ : show a) (_ : read a) : json a = {ToJson = show,
+ FromJson = numIn}
+
+val json_int = json_num
+val json_float = json_num
+
+val json_bool = {ToJson = fn b => if b then "true" else "false",
+ FromJson = fn s => if String.isPrefix {Full = s, Prefix = "true"} then
+ (True, String.substring s {Start = 4, Len = String.length s - 4})
+ else if String.isPrefix {Full = s, Prefix = "false"} then
+ (False, String.substring s {Start = 5, Len = String.length s - 5})
+ else
+ error <xml>JSON: bad boolean string: {[s]}</xml>}
+
+fun json_option [a] (j : json a) : json (option a) =
+ {ToJson = fn v => case v of
+ None => "null"
+ | Some v => j.ToJson v,
+ FromJson = fn s => if String.isPrefix {Full = s, Prefix = "null"} then
+ (None, String.substring s {Start = 4, Len = String.length s - 4})
+ else
+ let
+ val (v, s') = j.FromJson s
+ in
+ (Some v, s')
+ end}
+
+fun json_list [a] (j : json a) : json (list a) =
+ let
+ fun toJ' (ls : list a) : string =
+ case ls of
+ [] => ""
+ | x :: ls => "," ^ toJson j x ^ toJ' ls
+
+ fun toJ (x : list a) : string =
+ case x of
+ [] => "[]"
+ | x :: [] => "[" ^ toJson j x ^ "]"
+ | x :: ls => "[" ^ toJson j x ^ toJ' ls ^ "]"
+
+ fun fromJ (s : string) : list a * string =
+ let
+ fun fromJ' (s : string) : list a * string =
+ if String.length s = 0 then
+ error <xml>JSON list doesn't end with ']'</xml>
+ else
+ let
+ val ch = String.sub s 0
+ in
+ case ch of
+ #"]" => ([], String.substring s {Start = 1, Len = String.length s - 1})
+ | _ =>
+ let
+ val (x, s') = j.FromJson s
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 then
+ error <xml>JSON list doesn't end with ']'</xml>
+ else if String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+
+ val (ls, s'') = fromJ' s'
+ in
+ (x :: ls, s'')
+ end
+ end
+ in
+ if String.length s = 0 || String.sub s 0 <> #"[" then
+ error <xml>JSON list doesn't start with '[': {[s]}</xml>
+ else
+ fromJ' (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
+ end
+ in
+ {ToJson = toJ,
+ FromJson = fromJ}
+ end
+
+fun skipOne s =
+ let
+ fun skipOne s dquote squote brace bracket =
+ if String.length s = 0 then
+ s
+ else
+ let
+ val ch = String.sub s 0
+ val rest = String.suffix s 1
+ in
+ case ch of
+ #"\"" => skipOne rest (not dquote) squote brace bracket
+ | #"'" => skipOne rest dquote (not squote) brace bracket
+ | #"\\" => if String.length s >= 2 then
+ skipOne (String.suffix s 2) dquote squote brace bracket
+ else
+ ""
+ | #"{" => skipOne rest dquote squote (brace + 1) bracket
+ | #"}" => if brace = 0 then
+ s
+ else
+ skipOne rest dquote squote (brace - 1) bracket
+
+ | #"[" => skipOne rest dquote squote brace (bracket + 1)
+ | #"]" =>
+ if bracket = 0 then
+ s
+ else
+ skipOne rest dquote squote brace (bracket - 1)
+
+ | #"," =>
+ if not dquote && not squote && brace = 0 && bracket = 0 then
+ s
+ else
+ skipOne rest dquote squote brace bracket
+
+ | _ => skipOne rest dquote squote brace bracket
+ end
+ in
+ skipOne s False False 0 0
+ end
+
+fun json_record [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json $ts =
+ {ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [ident] [fn _ => string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc =>
+ escape name ^ ":" ^ j.ToJson v ^ (case acc of
+ "" => ""
+ | acc => "," ^ acc))
+ "" fl jss names r ^ "}",
+ FromJson = fn s =>
+ let
+ fun fromJ s (r : $(map option ts)) : $(map option ts) * string =
+ if String.length s = 0 then
+ error <xml>JSON object doesn't end in brace</xml>
+ else if String.sub s 0 = #"}" then
+ (r, String.substring s {Start = 1, Len = String.length s - 1})
+ else let
+ val (name, s') = unescape s
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
+ error <xml>No colon after JSON object field name</xml>
+ else
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+
+ val (r, s') = @foldR2 [json] [fn _ => string] [fn ts => $(map option ts) -> $(map option ts) * string]
+ (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name' acc r =>
+ if name = name' then
+ let
+ val (v, s') = j.FromJson s'
+ in
+ (r -- nm ++ {nm = Some v}, s')
+ end
+ else
+ let
+ val (r', s') = acc (r -- nm)
+ in
+ (r' ++ {nm = r.nm}, s')
+ end)
+ (fn r => (r, skipOne s'))
+ fl jss names r
+
+ val s' = skipSpaces s'
+ val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+ in
+ fromJ s' r
+ end
+ in
+ if String.length s = 0 || String.sub s 0 <> #"{" then
+ error <xml>JSON record doesn't begin with brace</xml>
+ else
+ let
+ val (r, s') = fromJ (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1}))
+ (@map0 [option] (fn [t ::_] => None) fl)
+ in
+ (@map2 [option] [fn _ => string] [ident] (fn [t] (v : option t) name =>
+ case v of
+ None => error <xml>Missing JSON object field {[name]}</xml>
+ | Some v => v) fl r names, s')
+ end
+ end}
+
+fun destrR [K] [f :: K -> Type] [fr :: K -> Type] [t ::: Type]
+ (f : p :: K -> f p -> fr p -> t)
+ [r ::: {K}] (fl : folder r) (v : variant (map f r)) (r : $(map fr r)) : t =
+ match v
+ (@Top.mp [fr] [fn p => f p -> t]
+ (fn [p] (m : fr p) (v : f p) => f [p] v m)
+ fl r)
+
+fun json_variant [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json (variant ts) =
+ {ToJson = fn r => let val jnames = @map2 [json] [fn _ => string] [fn x => json x * string]
+ (fn [t] (j : json t) (name : string) => (j, name)) fl jss names
+ in @destrR [ident] [fn x => json x * string]
+ (fn [p ::_] (v : p) (j : json p, name : string) =>
+ "{" ^ escape name ^ ":" ^ j.ToJson v ^ "}") fl r jnames
+ end,
+ FromJson = fn s =>
+ if String.length s = 0 || String.sub s 0 <> #"{" then
+ error <xml>JSON variant doesn't begin with brace</xml>
+ else
+ let
+ val (name, s') = unescape (skipSpaces (String.suffix s 1))
+ val s' = skipSpaces s'
+ val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then
+ error <xml>No colon after JSON object field name</xml>
+ else
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+
+ val (r, s') = (@foldR2 [json] [fn _ => string]
+ [fn ts => ts' :: {Type} -> [ts ~ ts'] => variant (ts ++ ts') * string]
+ (fn [nm ::_] [t ::_] [rest ::_] [[nm] ~ rest] (j : json t) name'
+ (acc : ts' :: {Type} -> [rest ~ ts'] => variant (rest ++ ts') * string) [fwd ::_] [[nm = t] ++ rest ~ fwd] =>
+ if name = name'
+ then
+ let val (v, s') = j.FromJson s'
+ in (make [nm] v, s')
+ end
+ else acc [fwd ++ [nm = t]]
+ )
+ (fn [fwd ::_] [[] ~ fwd] => error <xml>Unknown JSON object variant name {[name]}</xml>)
+ fl jss names) [[]] !
+
+ val s' = skipSpaces s'
+ val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then
+ skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1})
+ else
+ s'
+ in
+ if String.length s' = 0 then
+ error <xml>JSON object doesn't end in brace</xml>
+ else if String.sub s' 0 = #"}" then
+ (r, String.substring s' {Start = 1, Len = String.length s' - 1})
+ else error <xml>Junk after JSON value in object</xml>
+ end
+ }
+
+val json_unit : json unit = json_record {} {}
+
+functor Recursive (M : sig
+ con t :: Type -> Type
+ val json_t : a ::: Type -> json a -> json (t a)
+ end) = struct
+ open M
+
+ datatype r = Rec of t r
+
+ fun rTo (Rec x) = (json_t {ToJson = rTo,
+ FromJson = fn _ => error <xml>Tried to FromJson in ToJson!</xml>}).ToJson x
+
+ fun rFrom s =
+ let
+ val (x, s') = (json_t {ToJson = fn _ => error <xml>Tried to ToJson in FromJson!</xml>,
+ FromJson = rFrom}).FromJson s
+ in
+ (Rec x, s')
+ end
+
+ val json_r = {ToJson = rTo, FromJson = rFrom}
+end
diff --git a/lib/ur/json.urs b/lib/ur/json.urs
new file mode 100644
index 00000000..b4bd6350
--- /dev/null
+++ b/lib/ur/json.urs
@@ -0,0 +1,31 @@
+(** The JSON text-based serialization format *)
+
+class json
+
+val toJson : a ::: Type -> json a -> a -> string
+val fromJson : a ::: Type -> json a -> string -> a
+val fromJson' : a ::: Type -> json a -> string -> a * string
+
+val mkJson : a ::: Type -> {ToJson : a -> string,
+ FromJson : string -> a * string} -> json a
+
+val json_string : json string
+val json_int : json int
+val json_float : json float
+val json_bool : json bool
+val json_option : a ::: Type -> json a -> json (option a)
+val json_list : a ::: Type -> json a -> json (list a)
+
+val json_record : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json $ts
+val json_variant : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json (variant ts)
+
+val json_unit : json unit
+
+functor Recursive (M : sig
+ con t :: Type -> Type
+ val json_t : a ::: Type -> json a -> json (t a)
+ end) : sig
+ datatype r = Rec of M.t r
+
+ val json_r : json r
+end
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 6c6c896c..02567917 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -179,6 +179,13 @@ fun mapUX [tf :: Type] [ctx :: {Unit}]
<xml>{f [nm] [rest] r}{acc}</xml>)
<xml/>
+fun mapUX_rev [tf :: Type] [ctx :: {Unit}]
+ (f : nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => tf -> xml ctx [] []) =
+ @@foldR [fn _ => tf] [fn _ => xml ctx [] []]
+ (fn [nm :: Name] [u :: Unit] [rest :: {Unit}] [[nm] ~ rest] r acc =>
+ <xml>{acc}{f [nm] [rest] r}</xml>)
+ <xml/>
+
fun mapX [K] [tf :: K -> Type] [ctx :: {Unit}]
(f : nm :: Name -> t :: K -> rest :: {K}
-> [[nm] ~ rest] =>
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 8273db0c..ec098955 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -126,6 +126,10 @@ val mapUX : tf :: Type -> ctx :: {Unit}
-> (nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] =>
tf -> xml ctx [] [])
-> r ::: {Unit} -> folder r -> $(mapU tf r) -> xml ctx [] []
+val mapUX_rev : tf :: Type -> ctx :: {Unit}
+ -> (nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] =>
+ tf -> xml ctx [] [])
+ -> r ::: {Unit} -> folder r -> $(mapU tf r) -> xml ctx [] []
(* Generate some XML by mapping over a heterogenously-typed record *)
val mapX : K --> tf :: (K -> Type) -> ctx :: {Unit}
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 23:59:25 +0000