From ab3d80119a5e6bdf63e33ad1e3aea7558f637ffd Mon Sep 17 00:00:00 2001 From: Dave Gurnell Date: Tue, 12 Oct 2010 11:48:26 +0100 Subject: [PATCH] Added file-download-headers tofunction. --- all-mirrors-tests.ss | 15 +- csv/all-csv-tests.ss | 14 +- csv/render-test.ss | 71 +++-- csv/struct-test.ss | 31 +-- javascript/all-javascript-tests.ss | 23 +- javascript/lang-test.ss | 137 +++++---- javascript/op-test.ss | 39 ++- javascript/quote-test.ss | 11 +- javascript/response-test.ss | 9 +- javascript/syntax-test.ss | 427 ++++++++++++++--------------- plain/all-plain-tests.ss | 9 +- plain/response-test.ss | 103 +++---- plain/response.ss | 20 +- xml/all-xml-tests.ss | 19 +- xml/render-test.ss | 205 +++++++------- xml/response-test.ss | 55 ++-- xml/struct-test.ss | 51 ++-- xml/syntax-expand-test.ss | 141 +++++----- xml/syntax-prerender-test.ss | 149 +++++----- xml/util-test.ss | 59 ++-- 20 files changed, 759 insertions(+), 829 deletions(-) diff --git a/all-mirrors-tests.ss b/all-mirrors-tests.ss index 93ce79f..1dcace8 100644 --- a/all-mirrors-tests.ss +++ b/all-mirrors-tests.ss @@ -9,13 +9,8 @@ ; Tests ------------------------------------------ -(define all-mirrors-tests - (test-suite "mirrors" - all-plain-tests - all-csv-tests - all-javascript-tests - all-xml-tests)) - -; Provide statements ----------------------------- - -(provide all-mirrors-tests) +(define/provide-test-suite all-mirrors-tests + all-plain-tests + all-csv-tests + all-javascript-tests + all-xml-tests) diff --git a/csv/all-csv-tests.ss b/csv/all-csv-tests.ss index a9bab99..d27d0fc 100644 --- a/csv/all-csv-tests.ss +++ b/csv/all-csv-tests.ss @@ -6,13 +6,7 @@ "response-test.ss" "struct-test.ss") -; test-suite -(define all-csv-tests - (test-suite "csv" - struct-tests - render-tests - response-tests)) - -; Provide statements ----------------------------- - -(provide all-csv-tests) +(define/provide-test-suite all-csv-tests + struct-tests + render-tests + response-tests) diff --git a/csv/render-test.ss b/csv/render-test.ss index c1c343a..c8e04ca 100644 --- a/csv/render-test.ss +++ b/csv/render-test.ss @@ -18,41 +18,36 @@ ; Tests ------------------------------------------ ; test-suite -(define render-tests - (test-suite "render.ss" - - (test-case "atomic values" - (check-equal? (csv->string (cell "string")) "\"string\"") - (check-equal? (csv->string (cell "123")) "\"123\"") - (check-equal? (csv->string (cell "0123")) "\"0123\"") - (check-equal? (csv->string (cell 'symbol)) "\"symbol\"") - (check-equal? (csv->string (cell 123.456)) "123.456") - (check-equal? (csv->string (cell #t)) "yes") - (check-equal? (csv->string (cell #f)) "") - (check-equal? (csv->string (cell #"bytes")) "\"bytes\"") - (check-equal? (csv->string (cell (string->url "/u/r/l"))) "\"/u/r/l\"") - (check-equal? (csv->string (cell "\"string\" with quotes")) "\"\"\"string\"\" with quotes\"") - ; Times are rendered in the correct immediate time zone: - (check-equal? (csv->string (cell utc-winter-date)) "\"2003-02-01 12:34:56\"" "time-utc (GMT)") - (check-equal? (csv->string (cell tai-winter-date)) "\"2003-02-01 12:34:56\"" "time-utc (GMT)") - (check-equal? (csv->string (cell utc-summer-date)) "\"2003-07-01 12:34:56\"" "time-utc (BST)") - (check-equal? (csv->string (cell tai-summer-date)) "\"2003-07-01 12:34:56\"" "time-utc (BST)") - (parameterize ([current-tz "PST8PDT"]) - (check-equal? (csv->string (cell utc-winter-date)) "\"2003-02-01 04:34:56\"" "time-utc (PST)") - (check-equal? (csv->string (cell tai-winter-date)) "\"2003-02-01 04:34:56\"" "time-utc (PST)") - (check-equal? (csv->string (cell utc-summer-date)) "\"2003-07-01 04:34:56\"" "time-utc (PDT)") - (check-equal? (csv->string (cell tai-summer-date)) "\"2003-07-01 04:34:56\"" "time-utc (PDT)"))) - - (test-equal? "single row" - (csv->string (row (cell 1) (cell "2") (cell 3))) - "1,\"2\",3") - - (test-equal? "multiple rows" - (csv->string (sheet (row (cell 1) (cell 2) (cell 3)) - (row (cell 4) (cell 5) (cell 6)) - (row (cell 7) (cell 8) (cell 9)))) - (format "1,2,3~n4,5,6~n7,8,9")))) - -; Provide statements ----------------------------- - -(provide render-tests) +(define/provide-test-suite render-tests + + (test-case "atomic values" + (check-equal? (csv->string (cell "string")) "\"string\"") + (check-equal? (csv->string (cell "123")) "\"123\"") + (check-equal? (csv->string (cell "0123")) "\"0123\"") + (check-equal? (csv->string (cell 'symbol)) "\"symbol\"") + (check-equal? (csv->string (cell 123.456)) "123.456") + (check-equal? (csv->string (cell #t)) "yes") + (check-equal? (csv->string (cell #f)) "") + (check-equal? (csv->string (cell #"bytes")) "\"bytes\"") + (check-equal? (csv->string (cell (string->url "/u/r/l"))) "\"/u/r/l\"") + (check-equal? (csv->string (cell "\"string\" with quotes")) "\"\"\"string\"\" with quotes\"") + ; Times are rendered in the correct immediate time zone: + (check-equal? (csv->string (cell utc-winter-date)) "\"2003-02-01 12:34:56\"" "time-utc (GMT)") + (check-equal? (csv->string (cell tai-winter-date)) "\"2003-02-01 12:34:56\"" "time-utc (GMT)") + (check-equal? (csv->string (cell utc-summer-date)) "\"2003-07-01 12:34:56\"" "time-utc (BST)") + (check-equal? (csv->string (cell tai-summer-date)) "\"2003-07-01 12:34:56\"" "time-utc (BST)") + (parameterize ([current-tz "PST8PDT"]) + (check-equal? (csv->string (cell utc-winter-date)) "\"2003-02-01 04:34:56\"" "time-utc (PST)") + (check-equal? (csv->string (cell tai-winter-date)) "\"2003-02-01 04:34:56\"" "time-utc (PST)") + (check-equal? (csv->string (cell utc-summer-date)) "\"2003-07-01 04:34:56\"" "time-utc (PDT)") + (check-equal? (csv->string (cell tai-summer-date)) "\"2003-07-01 04:34:56\"" "time-utc (PDT)"))) + + (test-equal? "single row" + (csv->string (row (cell 1) (cell "2") (cell 3))) + "1,\"2\",3") + + (test-equal? "multiple rows" + (csv->string (sheet (row (cell 1) (cell 2) (cell 3)) + (row (cell 4) (cell 5) (cell 6)) + (row (cell 7) (cell 8) (cell 9)))) + (format "1,2,3~n4,5,6~n7,8,9"))) diff --git a/csv/struct-test.ss b/csv/struct-test.ss index 3b0a701..f6abc8b 100644 --- a/csv/struct-test.ss +++ b/csv/struct-test.ss @@ -6,21 +6,16 @@ ; Tests ---------------------------------------- ; test-suite -(define struct-tests - (test-suite "struct.ss" - - (test-equal? "single row with list arguments" - (row (cell 1) - (list (cell 2) - (list (cell 3)) - (cell 4)) - (cell 5)) - (row (cell 1) - (cell 2) - (cell 3) - (cell 4) - (cell 5))))) - -; Provide statements --------------------------- - -(provide struct-tests) +(define/provide-test-suite struct-tests + + (test-equal? "single row with list arguments" + (row (cell 1) + (list (cell 2) + (list (cell 3)) + (cell 4)) + (cell 5)) + (row (cell 1) + (cell 2) + (cell 3) + (cell 4) + (cell 5)))) diff --git a/javascript/all-javascript-tests.ss b/javascript/all-javascript-tests.ss index 8e2709e..48c5c01 100644 --- a/javascript/all-javascript-tests.ss +++ b/javascript/all-javascript-tests.ss @@ -11,17 +11,12 @@ "javascript-registry-test.ss" "sexp/module-test.ss") -(define all-javascript-tests - (test-suite "javascript" - op-tests - quote-tests - lang-tests - syntax-tests - #;render-tests - response-tests - javascript-registry-tests - module-tests)) - -; Provide statements ----------------------------- - -(provide all-javascript-tests) +(define/provide-test-suite all-javascript-tests + op-tests + quote-tests + lang-tests + syntax-tests + #;render-tests + response-tests + javascript-registry-tests + module-tests) diff --git a/javascript/lang-test.ss b/javascript/lang-test.ss index 9be1d2b..c95900f 100644 --- a/javascript/lang-test.ss +++ b/javascript/lang-test.ss @@ -23,72 +23,71 @@ ; Tests ------------------------------------------ -(define lang-tests - (test-suite "lang.ss" - - (test-case "js:var" - (check-exn exn:fail:contract? js:var "no args") - (check-equal? (apply js:var syms) - (make-VariableDeclaration #f (map (cut make-VariableInitializer #f <> <>) ids '(#f #f #f))) - "no initializers") - (check-equal? (apply js:var (map js:init syms numbers)) - (make-VariableDeclaration #f (map (cut make-VariableInitializer #f <> <>) ids numeric-lits)) - "initializers")) - - (test-case "js:begin" - (check-equal? (js:begin) - (make-BeginStatement #f (list)) - "no args") - (check-equal? (js:begin 1 2 3) - (make-BeginStatement #f (map (cut make-ExpressionStatement #f <>) numeric-lits)) - "multiple args")) - - (test-case "js:block" - (check-equal? (js:block) - (make-BlockStatement #f null) - "no args") - (check-equal? (js:block 1 2 3) - (make-BlockStatement #f (map (cut make-ExpressionStatement #f <>) numeric-lits)) - "args")) - - (test-case "js:if" - (check-equal? (apply js:if numbers) - (make-IfStatement #f - (make-NumericLiteral #f 1) - (make-ExpressionStatement #f (make-NumericLiteral #f 2)) - (make-ExpressionStatement #f (make-NumericLiteral #f 3))))) - - (test-case "js:do" - (check-equal? (js:do 1 #:while 2) - (make-DoWhileStatement #f - (make-ExpressionStatement #f (make-NumericLiteral #f 1)) - (make-NumericLiteral #f 2)))) - - (test-case "js:while" - (check-equal? (js:while 1 2) - (make-WhileStatement #f - (make-NumericLiteral #f 1) - (make-ExpressionStatement #f (make-NumericLiteral #f 2))))) - - (test-case "js:for-in" - (check-not-exn - (lambda () - (js:for-in (js:var 'key) - (js:object (js:field 'a 1) - (js:field 'b 2) - (js:field 'c 3)) - (js:call 'alert (js:id 'key)))) - "single iterator variable") - (check-exn exn:fail:contract? - (lambda () - (js:for-in (js:var 'key 'val) - (js:object (js:field 'a 1) - (js:field 'b 2) - (js:field 'c 3)) - (js:call 'alert (js:id 'key)))) - "multiple iterator variables")) - - #| +(define/provide-test-suite lang-tests + + (test-case "js:var" + (check-exn exn:fail:contract? js:var "no args") + (check-equal? (apply js:var syms) + (make-VariableDeclaration #f (map (cut make-VariableInitializer #f <> <>) ids '(#f #f #f))) + "no initializers") + (check-equal? (apply js:var (map js:init syms numbers)) + (make-VariableDeclaration #f (map (cut make-VariableInitializer #f <> <>) ids numeric-lits)) + "initializers")) + + (test-case "js:begin" + (check-equal? (js:begin) + (make-BeginStatement #f (list)) + "no args") + (check-equal? (js:begin 1 2 3) + (make-BeginStatement #f (map (cut make-ExpressionStatement #f <>) numeric-lits)) + "multiple args")) + + (test-case "js:block" + (check-equal? (js:block) + (make-BlockStatement #f null) + "no args") + (check-equal? (js:block 1 2 3) + (make-BlockStatement #f (map (cut make-ExpressionStatement #f <>) numeric-lits)) + "args")) + + (test-case "js:if" + (check-equal? (apply js:if numbers) + (make-IfStatement #f + (make-NumericLiteral #f 1) + (make-ExpressionStatement #f (make-NumericLiteral #f 2)) + (make-ExpressionStatement #f (make-NumericLiteral #f 3))))) + + (test-case "js:do" + (check-equal? (js:do 1 #:while 2) + (make-DoWhileStatement #f + (make-ExpressionStatement #f (make-NumericLiteral #f 1)) + (make-NumericLiteral #f 2)))) + + (test-case "js:while" + (check-equal? (js:while 1 2) + (make-WhileStatement #f + (make-NumericLiteral #f 1) + (make-ExpressionStatement #f (make-NumericLiteral #f 2))))) + + (test-case "js:for-in" + (check-not-exn + (lambda () + (js:for-in (js:var 'key) + (js:object (js:field 'a 1) + (js:field 'b 2) + (js:field 'c 3)) + (js:call 'alert (js:id 'key)))) + "single iterator variable") + (check-exn exn:fail:contract? + (lambda () + (js:for-in (js:var 'key 'val) + (js:object (js:field 'a 1) + (js:field 'b 2) + (js:field 'c 3)) + (js:call 'alert (js:id 'key)))) + "multiple iterator variables")) + + #| (test-case "js:for" (fail "Not implemented.")) (test-case "js:for-in" (fail "Not implemented.")) (test-case "js:break" (fail "Not implemented.")) @@ -118,8 +117,4 @@ (test-case "js:call" (fail "Not implemented.")) (test-case "js:id" (fail "Not implemented.")) |# - )) - -; Provide statements ----------------------------- - -(provide lang-tests) + ) diff --git a/javascript/op-test.ss b/javascript/op-test.ss index ec09fe1..c6c4264 100644 --- a/javascript/op-test.ss +++ b/javascript/op-test.ss @@ -3,26 +3,19 @@ (require "../test-base.ss" "op.ss") -(define op-tests - (test-suite "op.ss" - - (test-case "prefix-operator?" - (check-true (prefix-operator? '!) "!")) - - (test-case "postfix-operator?" - (check-true (postfix-operator? '++) "++") - (check-false (postfix-operator? '!) "!")) - - (test-case "infix-operator?" - (check-true (infix-operator? '==) "==") - (check-false (infix-operator? '=) "=")) - - (test-case "assignment-operator?" - (check-true (assignment-operator? '=) "=") - (check-false (assignment-operator? '==) "==")) - - )) - -; Provide statements ----------------------------- - -(provide op-tests) +(define/provide-test-suite op-tests + + (test-case "prefix-operator?" + (check-true (prefix-operator? '!) "!")) + + (test-case "postfix-operator?" + (check-true (postfix-operator? '++) "++") + (check-false (postfix-operator? '!) "!")) + + (test-case "infix-operator?" + (check-true (infix-operator? '==) "==") + (check-false (infix-operator? '=) "=")) + + (test-case "assignment-operator?" + (check-true (assignment-operator? '=) "=") + (check-false (assignment-operator? '==) "=="))) diff --git a/javascript/quote-test.ss b/javascript/quote-test.ss index 5a471b6..4614d6b 100644 --- a/javascript/quote-test.ss +++ b/javascript/quote-test.ss @@ -4,8 +4,7 @@ "quote.ss" "struct.ss") -(define quote-tests - (test-suite "quote.ss" +(define/provide-test-suite quote-tests (test-case "quote-id" (check-equal? (quote-identifier (make-Identifier #f 'a)) (make-Identifier #f 'a) "id") @@ -52,10 +51,4 @@ (test-case "wrap-block: multiple statements" (check-equal? (wrap-block (list 'x 'y)) (make-BlockStatement #f (list (make-ExpressionStatement #f (make-StringLiteral #f "x")) - (make-ExpressionStatement #f (make-StringLiteral #f "y")))))) - - )) - -; Provide statements ----------------------------- - -(provide quote-tests) + (make-ExpressionStatement #f (make-StringLiteral #f "y"))))))) diff --git a/javascript/response-test.ss b/javascript/response-test.ss index 2e10772..f983f58 100644 --- a/javascript/response-test.ss +++ b/javascript/response-test.ss @@ -3,8 +3,7 @@ (require "../test-base.ss" "../main.ss") -(define response-tests - (test-suite "response.ss" +(define/provide-test-suite response-tests (test-case "make-js-response" (check-not-exn @@ -16,8 +15,4 @@ (cut make-js-response #:message #"message" #:mime-type #"mime-type" - (js (alert "Hi"))))))) - -; Provide statements ----------------------------- - -(provide response-tests) \ No newline at end of file + (js (alert "Hi")))))) diff --git a/javascript/syntax-test.ss b/javascript/syntax-test.ss index 4367a4b..92be069 100644 --- a/javascript/syntax-test.ss +++ b/javascript/syntax-test.ss @@ -33,225 +33,220 @@ (define-javascript-syntax (!fast-for (id init test incr) stmt ...) (js (var [id init]) (while (! test) - stmt ... - incr))) + stmt ... + incr))) (define-javascript-syntax (!max a b) (js (? (> a b) a b))) ; Tests ------------------------------------------ -(define syntax-tests - (test-suite "syntax.ss" - - #:before (cut javascript-rendering-mode 'packed) - - (test-js "expander: decl" - (!var-debug [a 1] [b 2]) - "var a = 1; console.log(\"a\" + a); var b = 2; console.log(\"b\" + b);") - - (test-js "expander: stmt" - (!fast-for (i 0 (< i 10) (= i (+ i 1))) (alert i)) - "var i = 0; while (!(i < 10)) { alert(i); i = i + 1; }") - - (test-js "expander: expr" - (!max (!max a b) c) - "(a > b ? a : b) > c ? a > b ? a : b : c;") - - (test-js "decl: function" - (function sum3 (a b c) (return (+ a b c))) - "function sum3(a, b, c) { return a + b + c; }") - - (test-js "decl: anonymous function" - (function (a b c) (return (+ a b c))) - "function(a, b, c) { return a + b + c; }") - - (test-js "decl: anonymous function as an expression argument" - (+ ((function (a b c) (return (+ a b c)))) 1) - "(function(a, b, c) { return a + b + c; })() + 1;") - - (test-js "decl: var" - (var [x 1] [y (+ 2 3)]) - "var x = 1, y = 2 + 3;") - - (test-js "decl: var unquote" - (var [,(make-Identifier #f 'x) 1] [y ,(+ 2 3)]) - "var x = 1, y = 5;") - - (test-js "stmt: empty begin" (!begin) "") - - (test-js "stmt: begin" - (!begin (+ 1 2 3) - (!begin (var [x (+ 2 3 4)])) - (+ 3 4 5)) - "1 + 2 + 3; var x = 2 + 3 + 4; 3 + 4 + 5;") - - (test-js "stmt: begin containing nested function declarations" - (!begin (function a () (return)) - (function b () (return))) - "function a() { return; } function b() { return; }") - - - (test-js "stmt: empty block" (!block) "{}") - - (test-js "stmt: block" - (!block (+ 1 2 3) - (!block (var [x (+ 2 3 4)])) - (+ 3 4 5)) - "{ 1 + 2 + 3; { var x = 2 + 3 + 4; } 3 + 4 + 5; }") - - (test-js "stmt: raw (statement position)" - (!block (!raw "[")) - "{ [; }") - - (test-js "stmt: raw (expression position)" - (+ 1 (!raw "[") 2) - "1 + ([) + 2;") - - (test-js "stmt: if version 1" - (if x (return y)) - "if (x) return y;") - - (test-js "stmt: if version 2" - (if x (return y) (return z)) - "if (x) return y; else return z;") - - (test-js "stmt: for-in version 1" - (for-in (x (!array 1 2 3)) - (alert x)) - "for (x in [ 1, 2, 3 ]) alert(x);") - - (test-js "stmt: for-in version 2" - (for-in ((var x) (!array 1 2 3)) - (alert x)) - "for (var x in [ 1, 2, 3 ]) alert(x);") - - (test-js "stmt: for-in version 3" - (for-in ([key val] (!object [a 1] [b 2] [c 3])) - (alert (+ key ": " val))) - "for (key, val in { a: 1, b: 2, c: 3 }) alert(key + \": \" + val);") - - (test-exn "stmt: for-in version 4: for-in can only have one iterator variable" - exn:fail:contract? - (lambda () - (js (for-in ((var key val) (!object [a 1] [b 2] [c 3])) - (alert (+ key ": " val)))))) - - (test-js "stmt: throw" - (throw "x") - "throw \"x\";") - - (test-js "stmt: try version 1" - (try (+ 1 2) (+ 2 3) (catch e (+ 3 4)) (finally (+ 4 5))) - "try { 1 + 2; 2 + 3; } catch (e) { 3 + 4; } finally { 4 + 5; }") - - (test-js "stmt: try version 2" - (try (+ 1 2) (catch e (+ 3 4)) (finally (+ 4 5))) - "try { 1 + 2; } catch (e) { 3 + 4; } finally { 4 + 5; }") - - (test-js "stmt: unquote" - (!begin (while (< x 10) (post++ x)) - ,(js (while (> x 5) (post-- x)) - (while (< x 15) (pre++ x)))) - "while (x < 10) x++; while (x > 5) x--; while (x < 15) ++x;") - - (test-js "stmt: unquote-splicing" - (!begin (while (< x 10) (post++ x)) - ,@(list (js (while (> x 5) (post-- x))) - (js (while (< x 15) (pre++ x))))) - "while (x < 10) x++; while (x > 5) x--; while (x < 15) ++x;") - - (test-js "expr: array" (!array x "y" 123) "[ x, \"y\", 123 ];") - (test-js "expr: object" (!object [x 1] ["y" 2] [3 4]) "{ x: 1, \"y\": 2, 3: 4 };") - (test-js "expr: dot" (!dot x y z) "x.y.z;") - (test-js "expr: new" (new Array 1 2 3) "new Array(1, 2, 3);") - (test-js "expr: index" (!index (getStuff 1) (+ 2 3)) "getStuff(1)[2 + 3];") - (test-js "expr: infix" (+ 1 2 3) "1 + 2 + 3;") - (test-js "expr: prefix" (pre++ x) "++x;") - (test-js "expr: postfix" (post++ x) "x++;") - (test-js "expr: call" (x y z) "x(y, z);") - - (test-js "expr: conditional" - (? (== a b) c d) - "a == b ? c : d;") - - (test-js "expr: anonymous function wrapper" - ((function () (alert "Dave"))) - "(function() { alert(\"Dave\"); })();") - - (test-js "expr: quote" - (alert 'a-symbol) - "alert(\"a-symbol\");") - - (test-js "expr: unquote" - (return (+ 1 ,(js (/ 4 2)) 3)) - "return 1 + 4 / 2 + 3;") - - (test-js "expr: function with local variable declarations" - ((function () (var [x 1]) (return x))) - "(function() { var x = 1; return x; })();") - - (test-js "!dot: no inline procedure calls" - ((!dot a b) c) - "a.b(c);") - - (test-js "!dot: inline procedure calls only" - (!dot (a b c) (d e f) (g h i)) - "a(b, c).d(e, f).g(h, i);") - - (test-js "!dot: inline procedure calls mixed with normal identifiers" - (!dot (a b c) d e f (g h i)) - "a(b, c).d.e.f.g(h, i);") - - (test-js "!dot: inline procedure calls mixed with normal identifiers" - (!dot (+ "a" "b") length) - "(\"a\" + \"b\").length;") - - (test-js "!dot: first argument may be a true expression" - (!dot (+ "a" "b") length) - "(\"a\" + \"b\").length;") - - (test-js "!dot and !index" - (!dot (!index a 1) (!index b 2) c) - "a[1].b[2].c;") - - (test-js "!dot and function" - (!dot (function () (return 1)) (b c)) - "(function() { return 1; }).b(c);") - - (test-js "!dot and this" - (!dot this (doStuff)) - "this.doStuff();") - - (test-js "expr: !regexp: no arguments" - (!regexp "abc") - "/abc/;") - - (test-js "expr: !regexp: global" - (!regexp "abc" #:global? #t) - "/abc/g;") - - (test-js "expr: !regexp: case insensitive" - (!regexp "abc" #:ci? #t) - "/abc/i;") - - (test-js "expr: !regexp: global and case insensitive" - (!regexp "abc" #:global? #t #:ci? #t) - "/abc/gi;") - - (test-js "really long one-line program" - (function () - ,@(for/list ([x (in-range 0 100)]) - (js (alert x)))) - (format "function() { ~a}" - (for/fold ([str ""]) - ([x (in-range 0 100)]) - (string-append str "alert(x); ")))) - - (test-case "opt-js" - (check-equal? (opt-js #t (alert "Hello world!")) (js (alert "Hello world!"))) - (check-equal? (opt-js #f (alert "Hello world!")) (js))))) - -; Provide statements ----------------------------- - -(provide syntax-tests) +(define/provide-test-suite syntax-tests + + #:before (cut javascript-rendering-mode 'packed) + + (test-js "expander: decl" + (!var-debug [a 1] [b 2]) + "var a = 1; console.log(\"a\" + a); var b = 2; console.log(\"b\" + b);") + + (test-js "expander: stmt" + (!fast-for (i 0 (< i 10) (= i (+ i 1))) (alert i)) + "var i = 0; while (!(i < 10)) { alert(i); i = i + 1; }") + + (test-js "expander: expr" + (!max (!max a b) c) + "(a > b ? a : b) > c ? a > b ? a : b : c;") + + (test-js "decl: function" + (function sum3 (a b c) (return (+ a b c))) + "function sum3(a, b, c) { return a + b + c; }") + + (test-js "decl: anonymous function" + (function (a b c) (return (+ a b c))) + "function(a, b, c) { return a + b + c; }") + + (test-js "decl: anonymous function as an expression argument" + (+ ((function (a b c) (return (+ a b c)))) 1) + "(function(a, b, c) { return a + b + c; })() + 1;") + + (test-js "decl: var" + (var [x 1] [y (+ 2 3)]) + "var x = 1, y = 2 + 3;") + + (test-js "decl: var unquote" + (var [,(make-Identifier #f 'x) 1] [y ,(+ 2 3)]) + "var x = 1, y = 5;") + + (test-js "stmt: empty begin" (!begin) "") + + (test-js "stmt: begin" + (!begin (+ 1 2 3) + (!begin (var [x (+ 2 3 4)])) + (+ 3 4 5)) + "1 + 2 + 3; var x = 2 + 3 + 4; 3 + 4 + 5;") + + (test-js "stmt: begin containing nested function declarations" + (!begin (function a () (return)) + (function b () (return))) + "function a() { return; } function b() { return; }") + + + (test-js "stmt: empty block" (!block) "{}") + + (test-js "stmt: block" + (!block (+ 1 2 3) + (!block (var [x (+ 2 3 4)])) + (+ 3 4 5)) + "{ 1 + 2 + 3; { var x = 2 + 3 + 4; } 3 + 4 + 5; }") + + (test-js "stmt: raw (statement position)" + (!block (!raw "[")) + "{ [; }") + + (test-js "stmt: raw (expression position)" + (+ 1 (!raw "[") 2) + "1 + ([) + 2;") + + (test-js "stmt: if version 1" + (if x (return y)) + "if (x) return y;") + + (test-js "stmt: if version 2" + (if x (return y) (return z)) + "if (x) return y; else return z;") + + (test-js "stmt: for-in version 1" + (for-in (x (!array 1 2 3)) + (alert x)) + "for (x in [ 1, 2, 3 ]) alert(x);") + + (test-js "stmt: for-in version 2" + (for-in ((var x) (!array 1 2 3)) + (alert x)) + "for (var x in [ 1, 2, 3 ]) alert(x);") + + (test-js "stmt: for-in version 3" + (for-in ([key val] (!object [a 1] [b 2] [c 3])) + (alert (+ key ": " val))) + "for (key, val in { a: 1, b: 2, c: 3 }) alert(key + \": \" + val);") + + (test-exn "stmt: for-in version 4: for-in can only have one iterator variable" + exn:fail:contract? + (lambda () + (js (for-in ((var key val) (!object [a 1] [b 2] [c 3])) + (alert (+ key ": " val)))))) + + (test-js "stmt: throw" + (throw "x") + "throw \"x\";") + + (test-js "stmt: try version 1" + (try (+ 1 2) (+ 2 3) (catch e (+ 3 4)) (finally (+ 4 5))) + "try { 1 + 2; 2 + 3; } catch (e) { 3 + 4; } finally { 4 + 5; }") + + (test-js "stmt: try version 2" + (try (+ 1 2) (catch e (+ 3 4)) (finally (+ 4 5))) + "try { 1 + 2; } catch (e) { 3 + 4; } finally { 4 + 5; }") + + (test-js "stmt: unquote" + (!begin (while (< x 10) (post++ x)) + ,(js (while (> x 5) (post-- x)) + (while (< x 15) (pre++ x)))) + "while (x < 10) x++; while (x > 5) x--; while (x < 15) ++x;") + + (test-js "stmt: unquote-splicing" + (!begin (while (< x 10) (post++ x)) + ,@(list (js (while (> x 5) (post-- x))) + (js (while (< x 15) (pre++ x))))) + "while (x < 10) x++; while (x > 5) x--; while (x < 15) ++x;") + + (test-js "expr: array" (!array x "y" 123) "[ x, \"y\", 123 ];") + (test-js "expr: object" (!object [x 1] ["y" 2] [3 4]) "{ x: 1, \"y\": 2, 3: 4 };") + (test-js "expr: dot" (!dot x y z) "x.y.z;") + (test-js "expr: new" (new Array 1 2 3) "new Array(1, 2, 3);") + (test-js "expr: index" (!index (getStuff 1) (+ 2 3)) "getStuff(1)[2 + 3];") + (test-js "expr: infix" (+ 1 2 3) "1 + 2 + 3;") + (test-js "expr: prefix" (pre++ x) "++x;") + (test-js "expr: postfix" (post++ x) "x++;") + (test-js "expr: call" (x y z) "x(y, z);") + + (test-js "expr: conditional" + (? (== a b) c d) + "a == b ? c : d;") + + (test-js "expr: anonymous function wrapper" + ((function () (alert "Dave"))) + "(function() { alert(\"Dave\"); })();") + + (test-js "expr: quote" + (alert 'a-symbol) + "alert(\"a-symbol\");") + + (test-js "expr: unquote" + (return (+ 1 ,(js (/ 4 2)) 3)) + "return 1 + 4 / 2 + 3;") + + (test-js "expr: function with local variable declarations" + ((function () (var [x 1]) (return x))) + "(function() { var x = 1; return x; })();") + + (test-js "!dot: no inline procedure calls" + ((!dot a b) c) + "a.b(c);") + + (test-js "!dot: inline procedure calls only" + (!dot (a b c) (d e f) (g h i)) + "a(b, c).d(e, f).g(h, i);") + + (test-js "!dot: inline procedure calls mixed with normal identifiers" + (!dot (a b c) d e f (g h i)) + "a(b, c).d.e.f.g(h, i);") + + (test-js "!dot: inline procedure calls mixed with normal identifiers" + (!dot (+ "a" "b") length) + "(\"a\" + \"b\").length;") + + (test-js "!dot: first argument may be a true expression" + (!dot (+ "a" "b") length) + "(\"a\" + \"b\").length;") + + (test-js "!dot and !index" + (!dot (!index a 1) (!index b 2) c) + "a[1].b[2].c;") + + (test-js "!dot and function" + (!dot (function () (return 1)) (b c)) + "(function() { return 1; }).b(c);") + + (test-js "!dot and this" + (!dot this (doStuff)) + "this.doStuff();") + + (test-js "expr: !regexp: no arguments" + (!regexp "abc") + "/abc/;") + + (test-js "expr: !regexp: global" + (!regexp "abc" #:global? #t) + "/abc/g;") + + (test-js "expr: !regexp: case insensitive" + (!regexp "abc" #:ci? #t) + "/abc/i;") + + (test-js "expr: !regexp: global and case insensitive" + (!regexp "abc" #:global? #t #:ci? #t) + "/abc/gi;") + + (test-js "really long one-line program" + (function () + ,@(for/list ([x (in-range 0 100)]) + (js (alert x)))) + (format "function() { ~a}" + (for/fold ([str ""]) + ([x (in-range 0 100)]) + (string-append str "alert(x); ")))) + + (test-case "opt-js" + (check-equal? (opt-js #t (alert "Hello world!")) (js (alert "Hello world!"))) + (check-equal? (opt-js #f (alert "Hello world!")) (js)))) diff --git a/plain/all-plain-tests.ss b/plain/all-plain-tests.ss index 6ac35ab..209fb25 100644 --- a/plain/all-plain-tests.ss +++ b/plain/all-plain-tests.ss @@ -4,10 +4,5 @@ (require "response-test.ss") -(define all-plain-tests - (test-suite "plain" - response-tests)) - -; Provide statements ----------------------------- - -(provide all-plain-tests) +(define/provide-test-suite all-plain-tests + response-tests) diff --git a/plain/response-test.ss b/plain/response-test.ss index 7d9517a..562e3f9 100644 --- a/plain/response-test.ss +++ b/plain/response-test.ss @@ -2,51 +2,60 @@ (require "../test-base.ss") -(require "../main.ss") +(require web-server/http + "../main.ss") -(define response-tests - (test-suite "response.ss" - - (test-case "make-plain-response" - (check-not-exn - (cut make-plain-response - #:message "message" - #:mime-type "mime-type" - (list "Hi" #"Hi"))) - (check-not-exn - (cut make-plain-response - #:message #"message" - #:mime-type #"mime-type" - (list "Hi" #"Hi")))) - - (test-case "make-plain-response/incremental" - (check-not-exn - (cut make-plain-response/incremental - #:message "message" - #:mime-type "mime-type" - (lambda (output) - (output (list "Hi" #"Hi"))))) - (check-not-exn - (cut make-plain-response/incremental - #:message #"message" - #:mime-type #"mime-type" - (lambda (output) - (output (list "Hi" #"Hi")))))) - - (test-case "make-redirect-response" - (check-not-exn - (cut make-redirect-response - #:message "message" - "http://www.untyped.com")) - (check-not-exn - (cut make-redirect-response - #:message #"message" - (string->url "http://www.untyped.com"))) - (check-not-exn - (cut make-redirect-response - #:message #"message" - (string->url "http://www.untyped.com/!@£$%^&*()#-=_+[]{};'\\:\"|,./<>?`~")))))) - -; Provide statements ----------------------------- - -(provide response-tests) \ No newline at end of file +(define/provide-test-suite response-tests + + (test-case "make-plain-response" + (check-not-exn + (cut make-plain-response + #:message "message" + #:mime-type "mime-type" + (list "Hi" #"Hi"))) + (check-not-exn + (cut make-plain-response + #:message #"message" + #:mime-type #"mime-type" + (list "Hi" #"Hi")))) + + (test-case "make-plain-response/incremental" + (check-not-exn + (cut make-plain-response/incremental + #:message "message" + #:mime-type "mime-type" + (lambda (output) + (output (list "Hi" #"Hi"))))) + (check-not-exn + (cut make-plain-response/incremental + #:message #"message" + #:mime-type #"mime-type" + (lambda (output) + (output (list "Hi" #"Hi")))))) + + (test-case "make-redirect-response" + (check-not-exn + (cut make-redirect-response + #:message "message" + "http://www.untyped.com")) + (check-not-exn + (cut make-redirect-response + #:message #"message" + (string->url "http://www.untyped.com"))) + (check-not-exn + (cut make-redirect-response + #:message #"message" + (string->url "http://www.untyped.com/!@£$%^&*()#-=_+[]{};'\\:\"|,./<>?`~")))) + + (test-case "file-download-headers" + (define (expand-header header) + (cons (header-field header) + (header-value header))) + (check-equal? (map expand-header (file-download-headers "download.csv" "text/csv")) + (map expand-header (list* (make-header #"Content-Disposition" #"attachment; filename=download.csv") + (make-header #"Content-Type" #"text/csv") + no-cache-http-headers))) + (check-equal? (map expand-header (file-download-headers "script.js" "text/javascript" #:no-cache? #f)) + (map expand-header (list* (make-header #"Content-Disposition" #"attachment; filename=script.js") + (make-header #"Content-Type" #"text/javascript") + null))))) diff --git a/plain/response.ss b/plain/response.ss index e17105a..f70ba7b 100644 --- a/plain/response.ss +++ b/plain/response.ss @@ -2,7 +2,8 @@ (require "../base.ss") -(require web-server/servlet +(require web-server/http + web-server/servlet (unlib-in bytes number) "util.ss") @@ -74,6 +75,17 @@ headers)) (list #"Redirecting you - please wait..."))) +; string string [boolean] -> (listof header) +(define (file-download-headers filename mime-type #:no-cache? [no-cache? #t]) + (let* ([content-disposition-string (format "attachment; filename=~a" filename)] + [content-disposition-header (make-header #"Content-Disposition" (string->bytes/utf-8 content-disposition-string))] + [content-type-header (make-header #"Content-Type" (string->bytes/utf-8 mime-type))]) + (list* content-disposition-header + content-type-header + (if no-cache? + no-cache-http-headers + null)))) + ; Helpers ---------------------------------------- ; (U url string) -> bytes @@ -107,4 +119,8 @@ (#:code natural? #:message (or/c string? bytes?) #:headers (listof header?)) - response/full?)]) + response/full?)] + [file-download-headers + (->* (string? string?) + (#:no-cache? boolean?) + (listof header?))]) diff --git a/xml/all-xml-tests.ss b/xml/all-xml-tests.ss index 4df0cff..345afdc 100644 --- a/xml/all-xml-tests.ss +++ b/xml/all-xml-tests.ss @@ -9,15 +9,10 @@ "syntax-prerender-test.ss" "util-test.ss") -(define all-xml-tests - (test-suite "xml" - render-tests - struct-tests - syntax-expand-tests - syntax-prerender-tests - response-tests - util-tests)) - -; Provide statements ----------------------------- - -(provide all-xml-tests) +(define/provide-test-suite all-xml-tests + render-tests + struct-tests + syntax-expand-tests + syntax-prerender-tests + response-tests + util-tests) \ No newline at end of file diff --git a/xml/render-test.ss b/xml/render-test.ss index 2ef1191..731ccca 100644 --- a/xml/render-test.ss +++ b/xml/render-test.ss @@ -43,108 +43,103 @@ ; Tests ------------------------------------------ -(define render-tests - (test-suite "render.ss" - - (test-case "literals" - (check-xml #t "yes" "true") - (check-xml #f "" "false") - (check-xml 12345 "12345" "number") - (check-xml "blah &\"<>" "blah &"<>" "string") - (check-xml 'blah\&\"<> "blah&"<>" "symbol") - (check-xml #"blah &\"<>" "blah &"<>" "bytes") - ; Times are rendered in the correct immediate time zone: - (check-xml ,utc-winter-date "2003-02-01 12:34:56" "time-utc (GMT)") - (check-xml ,tai-winter-date "2003-02-01 12:34:56" "time-tai (GMT)") - (check-xml ,utc-summer-date "2003-07-01 12:34:56" "time-utc (BST)") - (check-xml ,tai-summer-date "2003-07-01 12:34:56" "time-tai (BST)") - (parameterize ([current-tz "PST8PDT"]) - (check-xml ,utc-winter-date "2003-02-01 04:34:56" "time-utc (PST)") - (check-xml ,tai-winter-date "2003-02-01 04:34:56" "time-tai (PST)") - (check-xml ,utc-summer-date "2003-07-01 04:34:56" "time-utc (PDT)") - (check-xml ,tai-summer-date "2003-07-01 04:34:56" "time-tai (PDT)"))) - - (test-case "raw" - (check-xml (!raw "&\"<>") "&\"<>" "string") - (check-xml (!raw 'dave) "dave" "symbol") - (check-xml (!raw ,url2) "http://www.example.com?a=b&c=d" "unquote") - (check-xml (!raw "a" 123) "a123" "multiple arguments")) - - (test-case "comment" - (check-xml (!comment "&\"<>") "" "string") - (check-xml (!comment 'dave) "" "symbol") - (check-xml (!comment ,url1) "" "unquote") - (check-xml (!comment "a" 123) "" "multiple arguments")) - - (test-case "cdata" - (check-xml (!cdata "&\"<>") "]]>" "string") - (check-xml (!cdata 'dave) "" "symbol") - (check-xml (!cdata ,url1) "" "unquote") - (check-xml (!cdata "a" 123) "" "multiple arguments") - (check-xml (script (!cdata "\n" ,(js (alert "Clicked")) "\n// ")) - "" - "unquote to js")) - - (test-case "pi" - (check-xml (!pi "&\"<>") "?>" "string") - (check-xml (!pi 'dave) "" "symbol") - (check-xml (!pi ,url1) "" "unquote") - (check-xml (!pi "a" 123) "" "multiple arguments")) - - (test-case "entities" - (check-xml (& nbsp) " " "symbol") - (check-xml (& 1234) "Ӓ" "integer") - (check-xml (& ,sym) "&symbol;" "unquote")) - - (test-case "elements" - (check-xml (br) - "
" - "empty") - (check-xml (h1 "Dave") - "

Dave

" - "children") - (check-xml (hr (@ [class "narrow"])) - "
" - "attributes") - (check-xml (script (@ [src "file.js"])) - "" - "attributes, no children, preserve singletons") - (check-xml (span (@ [title "&\"<>"]) "stuff") - "stuff" - "attributes and children") - (check-xml (a (@ ,(make-attribute 'href url1)) ,text) - "Text" - "unquote in attributes and children") - (check-xml (a (@ ,@(list (make-attribute 'href url1) (make-attribute 'class "blue"))) ,@(list text text)) - "TextText" - "unquote-splicing in attributes and children") - (check-xml (span (@ ,@(xml-attrs [title "title"] ,@null)) "text") - "text" - "unquote-splicing with null in attributes") - (check-xml (script ,(js (alert "Clicked 1"))) - "" - "unquote to js")) - - (test-case "expander" - (check-xml (!wrap "a" "b") - "aba") - (check-xml (!wrap "a" (!wrap "b" "c")) - "abcba") - (check-xml (!wrap (tag1) (!wrap (tag2) (tag3))) - "")) - - (test-case "javascript attribute" - (check-xml (a (@ [onclick ,(js (alert "Clicked 1") (alert "Clicked 2") (alert "Clicked 3"))]) "Click here") - "Click here")) - - (test-equal? "xml-attrs and javascript attribute values" - (xml->string (xml (a (@ ,@(xml-attrs [onclick ,(js (alert 10))])) "blah"))) - "blah") - - (test-equal? "xml-attrs and javascript attribute values" - (xml->string (xml (a (@ ,(xml-attrs [onclick ,(js (alert 10))])) "blah"))) - "blah"))) - -; Provide statements ----------------------------- - -(provide render-tests) +(define/provide-test-suite render-tests + + (test-case "literals" + (check-xml #t "yes" "true") + (check-xml #f "" "false") + (check-xml 12345 "12345" "number") + (check-xml "blah &\"<>" "blah &"<>" "string") + (check-xml 'blah\&\"<> "blah&"<>" "symbol") + (check-xml #"blah &\"<>" "blah &"<>" "bytes") + ; Times are rendered in the correct immediate time zone: + (check-xml ,utc-winter-date "2003-02-01 12:34:56" "time-utc (GMT)") + (check-xml ,tai-winter-date "2003-02-01 12:34:56" "time-tai (GMT)") + (check-xml ,utc-summer-date "2003-07-01 12:34:56" "time-utc (BST)") + (check-xml ,tai-summer-date "2003-07-01 12:34:56" "time-tai (BST)") + (parameterize ([current-tz "PST8PDT"]) + (check-xml ,utc-winter-date "2003-02-01 04:34:56" "time-utc (PST)") + (check-xml ,tai-winter-date "2003-02-01 04:34:56" "time-tai (PST)") + (check-xml ,utc-summer-date "2003-07-01 04:34:56" "time-utc (PDT)") + (check-xml ,tai-summer-date "2003-07-01 04:34:56" "time-tai (PDT)"))) + + (test-case "raw" + (check-xml (!raw "&\"<>") "&\"<>" "string") + (check-xml (!raw 'dave) "dave" "symbol") + (check-xml (!raw ,url2) "http://www.example.com?a=b&c=d" "unquote") + (check-xml (!raw "a" 123) "a123" "multiple arguments")) + + (test-case "comment" + (check-xml (!comment "&\"<>") "" "string") + (check-xml (!comment 'dave) "" "symbol") + (check-xml (!comment ,url1) "" "unquote") + (check-xml (!comment "a" 123) "" "multiple arguments")) + + (test-case "cdata" + (check-xml (!cdata "&\"<>") "]]>" "string") + (check-xml (!cdata 'dave) "" "symbol") + (check-xml (!cdata ,url1) "" "unquote") + (check-xml (!cdata "a" 123) "" "multiple arguments") + (check-xml (script (!cdata "\n" ,(js (alert "Clicked")) "\n// ")) + "" + "unquote to js")) + + (test-case "pi" + (check-xml (!pi "&\"<>") "?>" "string") + (check-xml (!pi 'dave) "" "symbol") + (check-xml (!pi ,url1) "" "unquote") + (check-xml (!pi "a" 123) "" "multiple arguments")) + + (test-case "entities" + (check-xml (& nbsp) " " "symbol") + (check-xml (& 1234) "Ӓ" "integer") + (check-xml (& ,sym) "&symbol;" "unquote")) + + (test-case "elements" + (check-xml (br) + "
" + "empty") + (check-xml (h1 "Dave") + "

Dave

" + "children") + (check-xml (hr (@ [class "narrow"])) + "
" + "attributes") + (check-xml (script (@ [src "file.js"])) + "" + "attributes, no children, preserve singletons") + (check-xml (span (@ [title "&\"<>"]) "stuff") + "stuff" + "attributes and children") + (check-xml (a (@ ,(make-attribute 'href url1)) ,text) + "Text" + "unquote in attributes and children") + (check-xml (a (@ ,@(list (make-attribute 'href url1) (make-attribute 'class "blue"))) ,@(list text text)) + "TextText" + "unquote-splicing in attributes and children") + (check-xml (span (@ ,@(xml-attrs [title "title"] ,@null)) "text") + "text" + "unquote-splicing with null in attributes") + (check-xml (script ,(js (alert "Clicked 1"))) + "" + "unquote to js")) + + (test-case "expander" + (check-xml (!wrap "a" "b") + "aba") + (check-xml (!wrap "a" (!wrap "b" "c")) + "abcba") + (check-xml (!wrap (tag1) (!wrap (tag2) (tag3))) + "")) + + (test-case "javascript attribute" + (check-xml (a (@ [onclick ,(js (alert "Clicked 1") (alert "Clicked 2") (alert "Clicked 3"))]) "Click here") + "Click here")) + + (test-equal? "xml-attrs and javascript attribute values" + (xml->string (xml (a (@ ,@(xml-attrs [onclick ,(js (alert 10))])) "blah"))) + "blah") + + (test-equal? "xml-attrs and javascript attribute values" + (xml->string (xml (a (@ ,(xml-attrs [onclick ,(js (alert 10))])) "blah"))) + "blah")) diff --git a/xml/response-test.ss b/xml/response-test.ss index e2c9120..4e50726 100644 --- a/xml/response-test.ss +++ b/xml/response-test.ss @@ -3,33 +3,28 @@ (require "../test-base.ss" "../main.ss") -(define response-tests - (test-suite "response.ss" - - (test-case "make-xml-response" - (check-not-exn - (cut make-xml-response - #:message "message" - #:mime-type "mime-type" - (xml "Hi"))) - (check-not-exn - (cut make-xml-response - #:message #"message" - #:mime-type #"mime-type" - (xml "Hi")))) - - (test-case "make-html-response" - (check-not-exn - (cut make-html-response - #:message "message" - #:mime-type "mime-type" - (xml "Hi"))) - (check-not-exn - (cut make-html-response - #:message #"message" - #:mime-type #"mime-type" - (xml "Hi")))))) - -; Provide statements ----------------------------- - -(provide response-tests) \ No newline at end of file +(define/provide-test-suite response-tests + + (test-case "make-xml-response" + (check-not-exn + (cut make-xml-response + #:message "message" + #:mime-type "mime-type" + (xml "Hi"))) + (check-not-exn + (cut make-xml-response + #:message #"message" + #:mime-type #"mime-type" + (xml "Hi")))) + + (test-case "make-html-response" + (check-not-exn + (cut make-html-response + #:message "message" + #:mime-type "mime-type" + (xml "Hi"))) + (check-not-exn + (cut make-html-response + #:message #"message" + #:mime-type #"mime-type" + (xml "Hi"))))) diff --git a/xml/struct-test.ss b/xml/struct-test.ss index 7ce8c8b..d7539ff 100644 --- a/xml/struct-test.ss +++ b/xml/struct-test.ss @@ -3,31 +3,26 @@ (require "../test-base.ss" "xml.ss") -(define struct-tests - (test-suite "struct.ss" - - (test-case "xml-quotable?" - (check-true (xml-quotable? "hi")) - (check-false (xml-quotable? (xml "hi")))) - - (test-case "xml+quotable?" - (check-true (xml+quotable? "hi")) - (check-true (xml+quotable? (xml "hi")))) - - (test-case "xml-quote" - (check-equal? (xml-quote #t) (xml* #t)) - (check-equal? (xml-quote #f) (xml* #f)) - (check-equal? (xml-quote "") (xml* "")) - (check-equal? (xml-quote (xml)) (xml)) - (check-not-equal? (xml-quote "") (xml* (!raw "")))) - - (test-case "xml-empty?" - (check-true (xml-empty? (xml))) - (check-true (xml-empty? (xml #f))) - (check-true (xml-empty? (xml ,(xml)))) - (check-true (xml-empty? (xml ,@(list (xml) (xml) (xml))))) - (check-true (xml-empty? (xml (!raw ""))))))) - -; Provide statements ----------------------------- - -(provide struct-tests) \ No newline at end of file +(define/provide-test-suite struct-tests + + (test-case "xml-quotable?" + (check-true (xml-quotable? "hi")) + (check-false (xml-quotable? (xml "hi")))) + + (test-case "xml+quotable?" + (check-true (xml+quotable? "hi")) + (check-true (xml+quotable? (xml "hi")))) + + (test-case "xml-quote" + (check-equal? (xml-quote #t) (xml* #t)) + (check-equal? (xml-quote #f) (xml* #f)) + (check-equal? (xml-quote "") (xml* "")) + (check-equal? (xml-quote (xml)) (xml)) + (check-not-equal? (xml-quote "") (xml* (!raw "")))) + + (test-case "xml-empty?" + (check-true (xml-empty? (xml))) + (check-true (xml-empty? (xml #f))) + (check-true (xml-empty? (xml ,(xml)))) + (check-true (xml-empty? (xml ,@(list (xml) (xml) (xml))))) + (check-true (xml-empty? (xml (!raw "")))))) diff --git a/xml/syntax-expand-test.ss b/xml/syntax-expand-test.ss index 2bf5fd9..41405a2 100644 --- a/xml/syntax-expand-test.ss +++ b/xml/syntax-expand-test.ss @@ -16,76 +16,71 @@ ; Tests ------------------------------------------ -(define syntax-expand-tests - (test-suite "syntax-expand.ss" - - (test-case "xml*: literals" - (check-equal? (xml* #t) (make-atom #t) "true") - (check-equal? (xml* #f) (make-atom #f) "false") - (check-equal? (xml* 12345) (make-atom 12345) "number") - (check-equal? (xml* "blah &\"<>") (make-atom "blah &\"<>") "string") - (check-equal? (xml* 'blah\&\"<>) (make-atom 'blah\&\"<>) "symbol") - (check-equal? (xml* #"blah&\"<>") (make-atom #"blah&\"<>") "bytes") - (check-equal? (xml* ,utc-date) (make-atom utc-date) "time-utc") - (check-equal? (xml* ,tai-date) (make-atom tai-date) "time-tai")) - - (test-case "xml*: raw" - (check-equal? (xml* (!raw "&\"<>")) (make-raw "&\"<>") "string") - (check-equal? (xml* (!raw 'dave)) (make-raw 'dave) "symbol") - (check-equal? (xml* (!raw ,test-url)) (make-raw "http://www.example.com") "unquote")) - - (test-case "xml*: comment" - (check-equal? (xml* (!comment "&\"<>")) (make-comment "&\"<>") "string") - (check-equal? (xml* (!comment 'dave)) (make-comment 'dave) "symbol") - (check-equal? (xml* (!comment ,test-url)) (make-comment "http://www.example.com") "unquote")) - - (test-case "xml*: cdata" - (check-equal? (xml* (!cdata "&\"<>")) (make-cdata "&\"<>") "string") - (check-equal? (xml* (!cdata 'dave)) (make-cdata 'dave) "symbol") - (check-equal? (xml* (!cdata ,test-url)) (make-cdata "http://www.example.com") "unquote")) - - (test-case "xml*: pi" - (check-equal? (xml* (!pi "&\"<>")) (make-pi "&\"<>") "string") - (check-equal? (xml* (!pi 'dave)) (make-pi 'dave) "symbol") - (check-equal? (xml* (!pi ,test-url)) (make-pi "http://www.example.com") "unquote")) - - (test-case "xml*: entities" - (check-equal? (xml* (& nbsp)) (make-entity 'nbsp) "symbol") - (check-equal? (xml* (& 1234)) (make-entity 1234) "integer") - (check-equal? (xml* (& ,sym)) (make-entity 'symbol) "unquote")) - - (test-case "xml*: elements" - (check-equal? (xml* (br)) - (make-element 'br null (make-block null)) - "empty") - (check-equal? (xml* (h1 "Dave")) - (make-element 'h1 null (make-atom "Dave")) - "children") - (check-equal? (xml* (hr (@ [class "narrow"]))) - (make-element 'hr (list (make-attribute 'class (make-atom "narrow"))) (make-block null)) - "attributes") - (check-equal? (xml* (span (@ [title "&\"<>"]) "stuff")) - (make-element 'span (list (make-attribute 'title (make-atom "&\"<>"))) (make-atom "stuff")) - "attributes and children") - (check-equal? (xml* (a (@ ,(make-attribute 'href test-url) [class ,text]) ,text)) - (make-element 'a (list (make-attribute 'href test-url) (make-attribute 'class text)) (make-atom text)) - "unquote in attributes and children") - (check-equal? (xml* (a (@ ,@(list (make-attribute 'href test-url) (make-attribute 'class "blue"))) - ,@(list text text))) - (make-element 'a - (list (make-attribute 'href test-url) (make-attribute 'class "blue")) - (make-block (list (make-atom text) (make-atom text)))) - "unquote-splicing in attributes and children")) - - (test-case "nested elements" - (check-equal? (xml (a (b (c)))) - (make-raw "") - "single children")) - - (test-equal? "top level unquote" - (xml* ,"stuff") - (make-atom "stuff")))) - -; Provide statements ----------------------------- - -(provide syntax-expand-tests) +(define/provide-test-suite syntax-expand-tests + + (test-case "xml*: literals" + (check-equal? (xml* #t) (make-atom #t) "true") + (check-equal? (xml* #f) (make-atom #f) "false") + (check-equal? (xml* 12345) (make-atom 12345) "number") + (check-equal? (xml* "blah &\"<>") (make-atom "blah &\"<>") "string") + (check-equal? (xml* 'blah\&\"<>) (make-atom 'blah\&\"<>) "symbol") + (check-equal? (xml* #"blah&\"<>") (make-atom #"blah&\"<>") "bytes") + (check-equal? (xml* ,utc-date) (make-atom utc-date) "time-utc") + (check-equal? (xml* ,tai-date) (make-atom tai-date) "time-tai")) + + (test-case "xml*: raw" + (check-equal? (xml* (!raw "&\"<>")) (make-raw "&\"<>") "string") + (check-equal? (xml* (!raw 'dave)) (make-raw 'dave) "symbol") + (check-equal? (xml* (!raw ,test-url)) (make-raw "http://www.example.com") "unquote")) + + (test-case "xml*: comment" + (check-equal? (xml* (!comment "&\"<>")) (make-comment "&\"<>") "string") + (check-equal? (xml* (!comment 'dave)) (make-comment 'dave) "symbol") + (check-equal? (xml* (!comment ,test-url)) (make-comment "http://www.example.com") "unquote")) + + (test-case "xml*: cdata" + (check-equal? (xml* (!cdata "&\"<>")) (make-cdata "&\"<>") "string") + (check-equal? (xml* (!cdata 'dave)) (make-cdata 'dave) "symbol") + (check-equal? (xml* (!cdata ,test-url)) (make-cdata "http://www.example.com") "unquote")) + + (test-case "xml*: pi" + (check-equal? (xml* (!pi "&\"<>")) (make-pi "&\"<>") "string") + (check-equal? (xml* (!pi 'dave)) (make-pi 'dave) "symbol") + (check-equal? (xml* (!pi ,test-url)) (make-pi "http://www.example.com") "unquote")) + + (test-case "xml*: entities" + (check-equal? (xml* (& nbsp)) (make-entity 'nbsp) "symbol") + (check-equal? (xml* (& 1234)) (make-entity 1234) "integer") + (check-equal? (xml* (& ,sym)) (make-entity 'symbol) "unquote")) + + (test-case "xml*: elements" + (check-equal? (xml* (br)) + (make-element 'br null (make-block null)) + "empty") + (check-equal? (xml* (h1 "Dave")) + (make-element 'h1 null (make-atom "Dave")) + "children") + (check-equal? (xml* (hr (@ [class "narrow"]))) + (make-element 'hr (list (make-attribute 'class (make-atom "narrow"))) (make-block null)) + "attributes") + (check-equal? (xml* (span (@ [title "&\"<>"]) "stuff")) + (make-element 'span (list (make-attribute 'title (make-atom "&\"<>"))) (make-atom "stuff")) + "attributes and children") + (check-equal? (xml* (a (@ ,(make-attribute 'href test-url) [class ,text]) ,text)) + (make-element 'a (list (make-attribute 'href test-url) (make-attribute 'class text)) (make-atom text)) + "unquote in attributes and children") + (check-equal? (xml* (a (@ ,@(list (make-attribute 'href test-url) (make-attribute 'class "blue"))) + ,@(list text text))) + (make-element 'a + (list (make-attribute 'href test-url) (make-attribute 'class "blue")) + (make-block (list (make-atom text) (make-atom text)))) + "unquote-splicing in attributes and children")) + + (test-case "nested elements" + (check-equal? (xml (a (b (c)))) + (make-raw "") + "single children")) + + (test-equal? "top level unquote" + (xml* ,"stuff") + (make-atom "stuff"))) diff --git a/xml/syntax-prerender-test.ss b/xml/syntax-prerender-test.ss index cd93cf6..20e14d8 100644 --- a/xml/syntax-prerender-test.ss +++ b/xml/syntax-prerender-test.ss @@ -15,80 +15,75 @@ ; Tests ------------------------------------------ -(define syntax-prerender-tests - (test-suite "syntax-prerender.ss" - - (test-case "xml: literals" - (check-equal? (xml #t) (make-raw "yes") "true") - (check-equal? (xml #f) (make-raw "") "false") - (check-equal? (xml 12345) (make-raw "12345") "number") - (check-equal? (xml "blah &\"<>") (make-raw "blah &"<>") "string") - (check-equal? (xml 'blah\&\"<>) (make-raw "blah&"<>") "symbol") - (check-equal? (xml #"blah&\"<>") (make-raw "blah&"<>") "bytes") - (check-equal? (xml ,utc-date) (make-atom utc-date) "time-utc") - (check-equal? (xml ,tai-date) (make-atom tai-date) "time-tai")) - - (test-case "xml: raw" - (check-equal? (xml (!raw "&\"<>")) (make-raw "&\"<>") "string") - (check-equal? (xml (!raw 'dave)) (make-raw "dave") "symbol") - (check-equal? (xml (!raw ,test-url)) (make-raw "http://www.example.com") "unquote")) - - (test-case "xml: comment" - (check-equal? (xml (!comment "&\"<>")) (make-raw "") "string") - (check-equal? (xml (!comment 'dave)) (make-raw "") "symbol") - (check-equal? (xml (!comment ,test-url)) (make-comment "http://www.example.com") "unquote")) - - (test-case "xml: cdata" - (check-equal? (xml (!cdata "&\"<>")) (make-raw "]]>") "string") - (check-equal? (xml (!cdata 'dave)) (make-raw "") "symbol") - (check-equal? (xml (!cdata ,test-url)) (make-cdata "http://www.example.com") "unquote")) - - (test-case "xml: pi" - (check-equal? (xml (!pi "&\"<>")) (make-raw "?>") "string") - (check-equal? (xml (!pi 'dave)) (make-raw "") "symbol") - (check-equal? (xml (!pi ,test-url)) (make-pi "http://www.example.com") "unquote")) - - (test-case "xml: entities" - (check-equal? (xml (& nbsp)) (make-raw " ") "symbol") - (check-equal? (xml (& 1234)) (make-raw "Ӓ") "integer")) - - (test-case "xml: elements" - (check-equal? (xml (br)) (make-raw "
") "empty") - (check-equal? (xml (h1 "Dave")) (make-raw "

Dave

") "children") - (check-equal? (xml (hr (@ [class "narrow"]))) (make-raw "
") "attributes") - (check-equal? (xml (span (@ [title "&\"<>"]) "stuff")) - (make-raw "stuff") - "attributes and children") - (check-equal? (xml (a (@ ,(make-attribute 'href test-url) [class ,text]) ,text)) - (make-block (list (make-raw "") - (make-atom text) - (make-raw ""))) - "unquote in attributes and children") - (check-equal? (xml (a (@ ,@(list (make-attribute 'href test-url) - (make-attribute 'class "blue"))) - ,@(list text text))) - (make-block (list (make-raw "") - (make-block (list (make-atom text) - (make-atom text))) - (make-raw ""))) - "unquote-splicing in attributes and children")) - - (test-case "nested elements" - (check-equal? (xml (a (b (c)))) - (make-raw "") - "single children")) - - (test-equal? "top level unquote" - (xml ,"stuff") - (make-atom "stuff")))) - -; Provide statements ----------------------------- - -(provide syntax-prerender-tests) +(define/provide-test-suite syntax-prerender-tests + + (test-case "xml: literals" + (check-equal? (xml #t) (make-raw "yes") "true") + (check-equal? (xml #f) (make-raw "") "false") + (check-equal? (xml 12345) (make-raw "12345") "number") + (check-equal? (xml "blah &\"<>") (make-raw "blah &"<>") "string") + (check-equal? (xml 'blah\&\"<>) (make-raw "blah&"<>") "symbol") + (check-equal? (xml #"blah&\"<>") (make-raw "blah&"<>") "bytes") + (check-equal? (xml ,utc-date) (make-atom utc-date) "time-utc") + (check-equal? (xml ,tai-date) (make-atom tai-date) "time-tai")) + + (test-case "xml: raw" + (check-equal? (xml (!raw "&\"<>")) (make-raw "&\"<>") "string") + (check-equal? (xml (!raw 'dave)) (make-raw "dave") "symbol") + (check-equal? (xml (!raw ,test-url)) (make-raw "http://www.example.com") "unquote")) + + (test-case "xml: comment" + (check-equal? (xml (!comment "&\"<>")) (make-raw "") "string") + (check-equal? (xml (!comment 'dave)) (make-raw "") "symbol") + (check-equal? (xml (!comment ,test-url)) (make-comment "http://www.example.com") "unquote")) + + (test-case "xml: cdata" + (check-equal? (xml (!cdata "&\"<>")) (make-raw "]]>") "string") + (check-equal? (xml (!cdata 'dave)) (make-raw "") "symbol") + (check-equal? (xml (!cdata ,test-url)) (make-cdata "http://www.example.com") "unquote")) + + (test-case "xml: pi" + (check-equal? (xml (!pi "&\"<>")) (make-raw "?>") "string") + (check-equal? (xml (!pi 'dave)) (make-raw "") "symbol") + (check-equal? (xml (!pi ,test-url)) (make-pi "http://www.example.com") "unquote")) + + (test-case "xml: entities" + (check-equal? (xml (& nbsp)) (make-raw " ") "symbol") + (check-equal? (xml (& 1234)) (make-raw "Ӓ") "integer")) + + (test-case "xml: elements" + (check-equal? (xml (br)) (make-raw "
") "empty") + (check-equal? (xml (h1 "Dave")) (make-raw "

Dave

") "children") + (check-equal? (xml (hr (@ [class "narrow"]))) (make-raw "
") "attributes") + (check-equal? (xml (span (@ [title "&\"<>"]) "stuff")) + (make-raw "stuff") + "attributes and children") + (check-equal? (xml (a (@ ,(make-attribute 'href test-url) [class ,text]) ,text)) + (make-block (list (make-raw "") + (make-atom text) + (make-raw ""))) + "unquote in attributes and children") + (check-equal? (xml (a (@ ,@(list (make-attribute 'href test-url) + (make-attribute 'class "blue"))) + ,@(list text text))) + (make-block (list (make-raw "") + (make-block (list (make-atom text) + (make-atom text))) + (make-raw ""))) + "unquote-splicing in attributes and children")) + + (test-case "nested elements" + (check-equal? (xml (a (b (c)))) + (make-raw "") + "single children")) + + (test-equal? "top level unquote" + (xml ,"stuff") + (make-atom "stuff"))) diff --git a/xml/util-test.ss b/xml/util-test.ss index 05766c9..f55e4fa 100644 --- a/xml/util-test.ss +++ b/xml/util-test.ss @@ -10,35 +10,30 @@ ; Tests ------------------------------------------ -(define util-tests - (test-suite "util.ss" - - (test-equal? "alist->attributes" - (alist->attributes `((title . "title") - (rowspan . 2) - (onclick . ,(js (alert "clicked"))))) - (list (make-attribute 'title "title") - (make-attribute 'rowspan 2) - (make-attribute 'onclick (js (alert "clicked"))))) - - (test-case "opt-xml" - (check-equal? (xml->string (xml "[" ,(opt-xml (even? 2) (span "stuff")) "]")) "[stuff]") - (check-equal? (xml->string (xml "[" ,(opt-xml (even? 1) (span "stuff")) "]")) "[]") - (check-equal? (xml->string (xml "[" ,(opt-xml (even? 2) (span "a") (span "b")) "]")) "[ab]") - (check-equal? (xml->string (xml "[" ,(opt-xml (even? 1) (span "a") (span "b")) "]")) "[]") - (check-equal? (xml->string (xml* "[" ,(opt-xml (even? 2) (span "stuff")) "]")) "[stuff]") - (check-equal? (xml->string (xml* "[" ,(opt-xml (even? 1) (span "stuff")) "]")) "[]")) - - (test-case "opt-xml-attr" - (let ([class 'theclass] - [noclass #f]) - (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr class))))) "
") - (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr noclass))))) "
") - (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr class noclass))))) "
") - (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr noclass class))))) "
") - (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr class noclass 123))))) "
") - (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr noclass class 123))))) "
"))))) - -; Provide statements ----------------------------- - -(provide util-tests) +(define/provide-test-suite util-tests + + (test-equal? "alist->attributes" + (alist->attributes `((title . "title") + (rowspan . 2) + (onclick . ,(js (alert "clicked"))))) + (list (make-attribute 'title "title") + (make-attribute 'rowspan 2) + (make-attribute 'onclick (js (alert "clicked"))))) + + (test-case "opt-xml" + (check-equal? (xml->string (xml "[" ,(opt-xml (even? 2) (span "stuff")) "]")) "[stuff]") + (check-equal? (xml->string (xml "[" ,(opt-xml (even? 1) (span "stuff")) "]")) "[]") + (check-equal? (xml->string (xml "[" ,(opt-xml (even? 2) (span "a") (span "b")) "]")) "[ab]") + (check-equal? (xml->string (xml "[" ,(opt-xml (even? 1) (span "a") (span "b")) "]")) "[]") + (check-equal? (xml->string (xml* "[" ,(opt-xml (even? 2) (span "stuff")) "]")) "[stuff]") + (check-equal? (xml->string (xml* "[" ,(opt-xml (even? 1) (span "stuff")) "]")) "[]")) + + (test-case "opt-xml-attr" + (let ([class 'theclass] + [noclass #f]) + (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr class))))) "
") + (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr noclass))))) "
") + (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr class noclass))))) "
") + (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr noclass class))))) "
") + (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr class noclass 123))))) "
") + (check-equal? (xml->string (xml (br (@ ,(opt-xml-attr noclass class 123))))) "
"))))