diff --git a/javascript/all-javascript-tests.ss b/javascript/all-javascript-tests.ss index 09c8aa3..8e2709e 100644 --- a/javascript/all-javascript-tests.ss +++ b/javascript/all-javascript-tests.ss @@ -7,7 +7,9 @@ "lang-test.ss" #;"render-test.ss" "response-test.ss" - "syntax-test.ss") + "syntax-test.ss" + "javascript-registry-test.ss" + "sexp/module-test.ss") (define all-javascript-tests (test-suite "javascript" @@ -16,7 +18,9 @@ lang-tests syntax-tests #;render-tests - response-tests)) + response-tests + javascript-registry-tests + module-tests)) ; Provide statements ----------------------------- diff --git a/javascript/javascript-registry-test.ss b/javascript/javascript-registry-test.ss new file mode 100644 index 0000000..6603b18 --- /dev/null +++ b/javascript/javascript-registry-test.ss @@ -0,0 +1,34 @@ +#lang scheme/base + +(require "../test-base.ss" + "javascript-registry.ss" + "javascript.ss") + +(define/provide-test-suite javascript-registry-tests + + #:before (lambda () (registry-clear!)) + + (test-case + "registered script returned from registry" + (after + (define script (js (+ 1 2))) + (registry-add! script) + (check-equal? (registry->string) (javascript->string script)) + + (registry-clear!))) + + (test-case + "registered scripts returned in order of registering" + (after + (define s1 (js (+ 1 2))) + (define s2 (js (/ 2 1))) + (registry-add! s1) + (registry-add! s2) + (check-equal? (registry->string) + (string-append + (javascript->string s1) + "\n" + (javascript->string s2))) + + (registry-clear!))) + ) \ No newline at end of file diff --git a/javascript/javascript-registry.ss b/javascript/javascript-registry.ss new file mode 100644 index 0000000..55abcd2 --- /dev/null +++ b/javascript/javascript-registry.ss @@ -0,0 +1,25 @@ +#lang typed-scheme + +(require/opaque-type Javascript javascript? "javascript.ss") +(require/typed scheme/string [string-join ((Listof String) String -> String)]) +(require/typed "javascript.ss" [javascript->string (Javascript -> String)]) + +(: registry (Listof Javascript)) +(define registry null) + +(: registry-add! (Javascript -> Void)) +(define (registry-add! s) + (set! registry (cons s registry))) + +(: registry->string (-> String)) +(define (registry->string) + (string-join (map javascript->string (reverse registry)) "\n")) + +(: registry-clear! (-> Void)) +(define (registry-clear!) + (set! registry null)) + +(provide + registry-add! + registry->string + registry-clear!) diff --git a/javascript/sexp/module-test.ss b/javascript/sexp/module-test.ss new file mode 100644 index 0000000..38ec9e6 --- /dev/null +++ b/javascript/sexp/module-test.ss @@ -0,0 +1,44 @@ +#lang scheme/base + +(require scheme/match + scheme/runtime-path + "../../test-base.ss" + "../javascript.ss" + "../javascript-registry.ss") + +(define-runtime-path here ".") +(define t1:script #f) + +(define/provide-test-suite module-tests + + ;; Dynamically requiring the test1.ss module here makes + ;; this test immune to the effects of other tests that may + ;; play around with the registry. If we statically + ;; required test1.ss, another test suite might clear the + ;; registry before we get run. + #:before (lambda () + (registry-clear!) + (set! t1:script (dynamic-require (build-path here "test1.ss") 'script))) + + (test-case + "module exports correct script binding" + (check-equal? t1:script + (js (function dave (a b) (+ a b)) + (function noel (a b) (/ a b))))) + + (test-case + "registry contains module's script" + (check + regexp-match? + (regexp-quote (javascript->string t1:script)) + (registry->string))) + + (test-case + "registry contains dependency's script" + (match (regexp-match-positions + (regexp-quote (javascript->string t1:script)) + (registry->string)) + [(list (cons start end)) + (check > start 0)] + [_ (fail "Registry does not contain test1.ss script")])) + ) \ No newline at end of file diff --git a/javascript/sexp/module.ss b/javascript/sexp/module.ss index 592a4ac..10ba073 100644 --- a/javascript/sexp/module.ss +++ b/javascript/sexp/module.ss @@ -3,7 +3,8 @@ (require (for-syntax scheme/base (planet untyped/unlib:3/debug) (planet untyped/unlib:3/syntax)) - "../javascript.ss") + "../javascript.ss" + "../javascript-registry.ss") (define-for-syntax (extract-requires stx) (let loop ([stx stx] [req-accum null] [stmt-accum null]) @@ -23,13 +24,15 @@ (syntax-case stx () [(module-begin) #'(#%plain-module-begin (begin #f))] [(module-begin req+stmt ...) - (with-syntax ([((require ...) (stmt ...)) + (with-syntax ([script (datum->syntax stx 'script)] + [((require ...) (stmt ...)) (extract-requires #'(req+stmt ...))]) #'(#%plain-module-begin require ... - (define ans (js stmt ...)) - (display (javascript->pretty-string ans)) - (provide ans)))])) + (define script (js stmt ...)) + (display (javascript->pretty-string script)) + (registry-add! script) + (provide script)))])) (provide (rename-out [module-begin #%module-begin]) (except-out (all-from-out scheme/base) #%module-begin)) diff --git a/javascript/sexp/test1.ss b/javascript/sexp/test1.ss new file mode 100644 index 0000000..b0aeb2d --- /dev/null +++ b/javascript/sexp/test1.ss @@ -0,0 +1,6 @@ +#lang s-exp "module.ss" + +(require (prefix-in foo: "test2.ss")) + +(function dave (a b) (+ a b)) +(function noel (a b) (/ a b)) \ No newline at end of file diff --git a/javascript/sexp/test2.ss b/javascript/sexp/test2.ss new file mode 100644 index 0000000..ec923c1 --- /dev/null +++ b/javascript/sexp/test2.ss @@ -0,0 +1,4 @@ +#lang s-exp "module.ss" + +(function matt (a b) (* a b)) +(function xian (a b) (- a b)) \ No newline at end of file