From 3ec6ef9fae03ea5325d3286c1b9884c5b9cf9278 Mon Sep 17 00:00:00 2001
From: Noel Welsh <noel@untyped.com>
Date: Wed, 24 Jun 2009 15:06:56 +0000
Subject: [PATCH] Added a very simple Javascript module system.

Any JS file written in the s-exp language (not the plain
language, yet) exports a single binding called 'script',
which contains the code as a Javascript structure. This
structure is also placed in Javascript registry
(javascript-registry.ss) where it can be later recalled
using registry->string. As modules are always loded in
topological order they will always be registered in the
correct order so dependencies come before scripts that
depend on them.

I have one final change to make: require statements for
Javascript inside a Javascript file should automatically
prefix their import so it doesn't clash with the script
binding created in the requiring module.

Note that javascript-registry.ss is written in Typed Scheme.
---
 javascript/all-javascript-tests.ss     |  8 +++--
 javascript/javascript-registry-test.ss | 34 ++++++++++++++++++++
 javascript/javascript-registry.ss      | 25 +++++++++++++++
 javascript/sexp/module-test.ss         | 44 ++++++++++++++++++++++++++
 javascript/sexp/module.ss              | 13 +++++---
 javascript/sexp/test1.ss               |  6 ++++
 javascript/sexp/test2.ss               |  4 +++
 7 files changed, 127 insertions(+), 7 deletions(-)
 create mode 100644 javascript/javascript-registry-test.ss
 create mode 100644 javascript/javascript-registry.ss
 create mode 100644 javascript/sexp/module-test.ss
 create mode 100644 javascript/sexp/test1.ss
 create mode 100644 javascript/sexp/test2.ss

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