substrate-lang 0.10.0 → 0.10.2

package/std/package.sub

@@ -1,6 +1,6 @@
 (package std
-  (version "0.10.0")
-  (substrate "0.10.0")
+  (version "0.10.2")
+  (substrate "0.10.2")
   (exports archive/tar browser/chromium browser/devtools compress/deflate compress/gzip compress/inflate crypto/hmac
            crypto/password crypto/sha1
            crypto/sha256 crypto/sha512 doc/doc doc/html doc/root doc/text encoding/base64 encoding/json encoding/utf8
@@ -8,6 +8,7 @@
            http/route http/server http/session http/sse http/sse-client http/static http/test http/token http/url
            http/websocket log/log meta/derive meta/equal meta/method meta/type-info package/files package/hash
            package/manifest package/map package/pack package/path package/read package/site package/store test/browser
-           test/build test/run test/session test/test vector/vector web/canvas web/dom web/gpu web/patches)
+           test/build test/run test/session test/test vector/vector web/canvas web/dom web/gpu web/gpu-commands
+           web/patches)
   (tests "tests/archive/*.sub" "tests/compress/*.sub" "tests/crypto/*.sub" "tests/encoding/*.sub" "tests/http/*.sub"
          "tests/log/*.sub" "tests/meta/*.sub" "tests/test/*.sub" "tests/vector/*.sub"))

package/std/test/browser.sub

@@ -105,13 +105,13 @@
 
 (define (%browser-step! [s string]) (page-step! s))
 
-(define (browser-opened [spec string] [html string] [url string] [args (slice string)] [server (fn ())] [message string])
-                        -> browser
+(define (browser-opened [spec string] [html string] [release bool] [url string] [args (slice string)] [server (fn ())]
+                        [message string]) -> browser
   (let ([address string])
     (unless (env-get "SUBSTRATE_DEVTOOLS" (& address) 0)
       (throw test-failed (lines-joined message "a test that opens a browser needs (browser) in the tests clause of its package's package.sub")))
     (when (== (-> address length) 0) (throw test-skipped "need Chromium"))
-    (let ([dir (site-built spec html message)] [why error] [p (ptr page) 0])
+    (let ([dir (site-built spec html release message)] [why error] [p (ptr page) 0])
       (unless (page-open dir (with-args url args) address server (& p) (& why))
         (throw test-failed (lines-joined message (error-text (& why)))))
       (browser #:page p))))
@@ -126,28 +126,31 @@
       (url-add-form-value! (& b) (@ args i)))
     (buffer-string (& b))))
 
-(struct built [spec string] [html string] [dir string])
+(struct built [spec string] [html string] [release bool] [dir string])
 
 (define made buffer)
 
 ;; Builds spec's site in the test's scratch directory, once per test.
-(define (site-built [spec string] [html string] [message string]) -> string
+(define (site-built [spec string] [html string] [release bool] [message string]) -> string
   (let* ([all (cast (ptr built) (-> made bytes))] [n (/ (-> made length) (sizeof built))]
          [base (base-of spec)] [name (if (ends? base ".sub") (slice base 0 (- (-> base length) 4)) base)]
          [dir (joined-path (joined-path (scratch-directory) "sites") name)] [info fs-info] [err (make-buffer)]
          [b built])
     (for ([i u32 0]) (< i n) (+= i 1)
       (let ([m (& (@ all i))])
-        (when (and (== (-> m spec) spec) (== (-> m html) html)) (return (-> m dir)))
+        (when (and (== (-> m spec) spec) (== (-> m html) html) (== (-> m release) release)) (return (-> m dir)))
         (when (== (-> m dir) dir) (set! dir (numbered dir n)))))
     (let ([p (planned spec name message)])
       (when (> (-> html length) 0) (set! (-> p html) html))
+      (build-ready!)
       (unless (site-write! (& p) dir (toolchain) (& err))
         (throw test-failed (lines-joined message (buffer-string (& err)))))
       (unless (and (fs-stat (-> p program) (& info) 0) (== (-> info kind) fs-directory))
-        (unless (program-write! (-> p program) (joined-path dir "program") (& err))
-          (throw test-failed (lines-joined message (buffer-string (& err)))))))
-    (set! b (built #:spec spec #:html html #:dir dir))
+        (unless (program-write! (-> p program) (joined-path dir "program") release (& err))
+          (throw test-failed (lines-joined message (buffer-string (& err))))))
+      (when (and release (not (site-release! dir (& err))))
+        (throw test-failed (lines-joined message (buffer-string (& err))))))
+    (set! b (built #:spec spec #:html html #:release release #:dir dir))
     (buffer-add! (& made) (slice (cast (ptr u8) (& b)) (sizeof built)))
     dir))
 
@@ -367,18 +370,21 @@
   (define (with-browser-form [s datum]) -> datum
     (syntax-match s
       [(_ ((? identifier? b) (? text? file) options ...) body ...)
-       (let ([html (literal '"")] [url (literal '"")] [args (no-fields)] [server #'(cast (fn ()) 0)] [l options])
+       (let ([html (literal '"")] [release #'#f] [url (literal '"")] [args (no-fields)] [server #'(cast (fn ()) 0)]
+             [l options])
          (while (pair? l)
            (unless (and (keyword? (syntax-e (car l))) (pair? (cdr l)))
              (raise-syntax-error 'with-browser "expected a keyword and its value" (car l)))
            (let ([k (keyword->string (syntax-e (car l)))] [v (cadr l)])
              (cond [(and (== k "html") (text? v)) (set! html (path-of s v))]
+                   [(== k "release") (set! release v)]
                    [(and (== k "url") (text? v)) (set! url v)]
                    [(== k "args") (set! args (arguments v))]
                    [(== k "server") (set! server v)]
-                   [else (raise-syntax-error 'with-browser "the options are #:html \"file\", #:url \"url\", #:args and #:server function" (car l))]))
+                   [else (raise-syntax-error 'with-browser "the options are #:html \"file\", #:release #t, #:url \"url\", #:args and #:server function" (car l))]))
            (set! l (cddr l)))
-         #`(let ([#,b (browser-opened #,(if (named? (syntax-e file)) file (path-of s file)) #,html #,url #,args #,server
+         #`(let ([#,b (browser-opened #,(if (named? (syntax-e file)) file (path-of s file)) #,html #,release #,url #,args
+                                      #,server
                                       #,(literal (format "~a:~a: (with-browser (~s ~s) ...)"
                                                          `(,(syntax-source s) ,(syntax-line s) ,(syntax->datum b)
                                                            ,(syntax-e file)))))])
@@ -386,8 +392,8 @@
                [catch-all (browser-closed! #,b) (rethrow)])
              (%browser-step! "")
              (browser-closed! #,b)))]
-      [_ (raise-syntax-error 'with-browser "expected (with-browser (name \"site or program.sub\" [#:html \"index.html\"] [#:url \"url\"] [#:args (\"argument\" ...)]
-                                       [#:server function]) body ...)" s)]))
+      [_ (raise-syntax-error 'with-browser "expected (with-browser (name \"site or program.sub\" [#:html \"index.html\"] [#:release #t] [#:url \"url\"]
+                                       [#:args (\"argument\" ...)] [#:server function]) body ...)" s)]))
 
   ;; The program's arguments from #:args: either a list of strings, or an expression that gives a slice of strings.
   (define (arguments [v datum]) -> datum

package/std/test/build.sub

@@ -1,4 +1,5 @@
 ;; Building programs during a test: expect-compile-error, and program-write!, which with-browser uses to build sites.
+;; build-ready! gives the compiler the test program's toolchain, module map and cache, once.
 (require-unqualified compiler/macros)
 (require-unqualified compiler/expander)
 (require-unqualified compiler/roots)
@@ -9,12 +10,12 @@
 (require-unqualified "test.sub")
 (require-unqualified "compare.sub")
 
-(provide expect-compile-error program-write!)
+(provide expect-compile-error program-write! build-ready!)
 
 (define ready bool #f)
 (define directory string)
 
-(define (ready!)
+(define (build-ready!)
   (unless ready
     (set! ready #t)
     (let ([why error] [toolchain string] [map-file string] [cache string])
@@ -29,19 +30,20 @@
 
 ;; Builds the program at path into out, both relative to the package's directory, with the test program's module map
 ;; and cache. Returns #f with the compile error in err if it does not compile.
-(define (program-write! [path string] [out string] [err (ptr buffer)]) -> bool
-  (ready!)
+(define (program-write! [path string] [out string] [strip bool] [err (ptr buffer)]) -> bool
+  (build-ready!)
   (let ([full (resolved-path directory path)] [to (resolved-path directory out)])
     (set-display-directory! (string->datum (parent-of full)))
     (fs-remove to #t 0)
-    (try (begin (write-program! 0 (string->datum full) (string->datum to) #f) #t)
+    (try (begin (write-program! 0 (string->datum full) (string->datum to) strip) #t)
          [catch compile-error (message blamed loc)
            (write-error err message blamed loc)
            #f])))
 
 (define (compile-error-check [path string] [text string] [message string])
   (let ([err (make-buffer)])
-    (when (program-write! path (joined-path (joined-path (scratch-directory) "programs") (program-name path)) (& err))
+    (when (program-write! path (joined-path (joined-path (scratch-directory) "programs") (program-name path)) #f
+                          (& err))
       (failure! message "the file compiled"))
     (unless (contains? (buffer-string (& err)) text) (failure! message (text-of "its compile error is\n" (buffer-string (& err)))))
     (buffer-free! (& err))))

package/std/test/page/agent.mjs

@@ -74,8 +74,14 @@ const same = (a, b) => a.length === b.length && a.every((x, i) => x === b[i]);
 // nameOf names drawn images and sounds by the path of the site's asset with the same bytes.
 async function nameOf(bytes, otherwise) {
   if (!assets) {
-    const listed = (await (await fetch('/assets.list')).text()).split('\n').filter((p) => p !== '');
-    assets = await Promise.all(listed.map(async (p) => [`/${p}`, new Uint8Array(await (await fetch(`/${p}`)).arrayBuffer())]));
+    const start = document.querySelector('script[src$="host/web/start.mjs"]');
+    const list = start ? new URL('../../assets.list', start.src) : new URL('/assets.list', location.href);
+    const lines = (await (await fetch(list)).text()).split('\n').filter((l) => l !== '');
+    assets = await Promise.all(lines.map(async (line) => {
+      const [path, url = path] = line.split('\t');
+      const from = new URL(url.split('/').map(encodeURIComponent).join('/'), location.href);
+      return [`/${path}`, new Uint8Array(await (await fetch(from)).arrayBuffer())];
+    }));
   }
   const found = assets.find(([, b]) => same(b, bytes));
   return found ? found[0] : otherwise;

package/std/web/canvas.sub

@@ -1,5 +1,5 @@
 ;; Drawing on a <canvas> element: rectangles, paths, circles, text, images and transforms. The calls write into the
-;; page's patches (patches.sub) between canvas-begin! and canvas-end!, and a call made outside them draws nothing.
+;; patches (patches.sub) between canvas-begin! and canvas-end!, and a call made outside them draws nothing.
 (require-unqualified std/web/patches)
 
 (provide canvas-begin! canvas-end! canvas-drawing?
@@ -15,7 +15,7 @@
 (define begun u32 0)
 
 (define (canvas-begin! [node u32])
-  (words! (slice (array-of u32 13 node 0)))
+  (words! (slice (array-of u32 11 node 0)))
   (set! drawing (-> (dom-patches) length))
   (set! begun (dom-flushes)))
 
@@ -90,12 +90,12 @@
 
 (define next-image u32 1)
 
-(define (canvas-load-image! [path string]) -> u32
+(define (canvas-load-image! [path string] [tag (ptr void)]) -> u32
   (if (canvas-drawing?)
       0
       (let ([id next-image])
         (+= next-image 1)
-        (dom-image! id path)
+        (dom-image! id path tag)
         id)))
 
 (define (canvas-draw-sprite! [image u32] [cell-width f64] [cell-height f64] [frame u32] [x f64] [y f64] [flip bool])

package/std/web/dom.sub

@@ -1,9 +1,25 @@
-;; The page: the host module "dom" and the patches that patches.sub writes. dom-flush! sends the patches, and
-;; dom-event-text and dom-event-truths read the current event.
+;; The document: the host module "dom" and the patches that patches.sub writes. dom-flush! sends the patches. A read
+;; takes a name that walks from a node, or from the current event, through the document's objects: a property's name, or
+;; names joined by dots. It gives a number, with true as 1, or text. The text lasts until the patches are sent. dom-is
+;; and dom-event-is also take a node, and say whether the name leads to it. (dom-is node dom-document "activeElement")
+;; says whether the node has the focus. dom-event-call calls a method of the current event.
 (require-unqualified host-dom host/web/dom)
 (require-unqualified patches "patches.sub")
 
-(provide (all-from-out host-dom) (all-from-out patches) dom-flush! dom-event-text dom-event-truths)
+(provide (all-from-out host-dom) (all-from-out patches) dom-flush! dom-element dom-event-number dom-event-text
+         dom-event-call dom-event-is dom-read-number dom-read-text dom-is)
+
+(import event-number "dom" "event_number" (i32 i32 -> f64))
+(import event-text "dom" "event_text" (i32 i32 i32 -> i32))
+(import event-call "dom" "event_call" (i32 i32 ->))
+(import event-is "dom" "event_is" (i32 i32 i32 -> i32))
+(import read-number "dom" "read_number" (i32 i32 i32 -> f64))
+(import read-text "dom" "read_text" (i32 i32 i32 i32 -> i32))
+(import is "dom" "is" (i32 i32 i32 i32 -> i32))
+
+(define (dom-element [id string]) -> u32
+  (let ([n (dom-new-node!)])
+    (if (== (dom-bind-element (cast i32 (-> id bytes)) (cast i32 (-> id length)) (cast i32 n)) 0) 0 n)))
 
 (define (dom-flush!)
   (let* ([b (dom-patches)] [n (-> b length)])
@@ -12,12 +28,30 @@
       (dom-apply (cast i32 (-> b bytes)) n))
     (dom-discard!)))
 
-;; The current event's text: its target's value when which is 0, or its key when which is 1.
-(define (dom-event-text [which u32]) -> string
-  (let* ([n u32 0] [s (cast (ptr u8) (if (== which 0) (dom-event-value (cast i32 (& n))) (dom-event-key (cast i32 (& n)))))]
-         [p (cast (ptr u8) (dom-frame-alloc n))])
-    (memcpy p s n)
-    (free s)
-    (cast string (slice p n))))
+(define (kept-text [p (ptr u8)] [n u32]) -> string
+  (let ([copy (cast (ptr u8) (dom-frame-alloc n))])
+    (memcpy copy p n)
+    (free p)
+    (cast string (slice copy n))))
+
+(define (dom-event-number [path string]) -> f64 (event-number (cast i32 (-> path bytes)) (cast i32 (-> path length))))
+
+(define (dom-event-text [path string]) -> string
+  (let* ([n u32 0] [p (event-text (cast i32 (-> path bytes)) (cast i32 (-> path length)) (cast i32 (& n)))])
+    (kept-text (cast (ptr u8) p) n)))
+
+(define (dom-event-call [method string]) (event-call (cast i32 (-> method bytes)) (cast i32 (-> method length))))
+
+(define (dom-read-number [node u32] [path string]) -> f64
+  (read-number (cast i32 node) (cast i32 (-> path bytes)) (cast i32 (-> path length))))
+
+(define (dom-read-text [node u32] [path string]) -> string
+  (let* ([n u32 0]
+         [p (read-text (cast i32 node) (cast i32 (-> path bytes)) (cast i32 (-> path length)) (cast i32 (& n)))])
+    (kept-text (cast (ptr u8) p) n)))
+
+(define (dom-event-is [node u32] [path string]) -> bool
+  (!= (event-is (cast i32 node) (cast i32 (-> path bytes)) (cast i32 (-> path length))) 0))
 
-(define (dom-event-truths) -> u32 (cast u32 (dom-event-flags)))
+(define (dom-is [node u32] [from u32] [path string]) -> bool
+  (!= (is (cast i32 node) (cast i32 from) (cast i32 (-> path bytes)) (cast i32 (-> path length))) 0))