grabbing the js stuff from js-vm

lang/js-conditional/js-conditional.rkt

@@ -0,0 +1,52 @@
+#lang scheme/base
+(require (for-syntax racket/base 
+                     racket/file
+                     racket/string
+                     syntax/parse
+                     syntax/modresolve
+                     "record.rkt"))
+
+(define-for-syntax (my-resolve-path a-module-path)
+  (parameterize ([current-directory (or (current-load-relative-directory)
+                                        (current-directory))])
+    (resolve-module-path a-module-path #f)))
+  
+
+(define-for-syntax (read-implementation a-module-path)
+  (let ([a-path (my-resolve-path a-module-path)])
+    (file->string a-path)))
+
+
+(define-syntax (declare-conditional-implementation stx)
+  (syntax-parse stx
+    [(_ #:racket racket-module-name
+        #:javascript (javascript-module-name ...))
+     (with-syntax 
+         ([resolved-racket-module-name 
+           (my-resolve-path (syntax-e #'racket-module-name))]
+          [impl
+           (string-join 
+            (map (compose read-implementation syntax-e)
+                 (syntax->list #'(javascript-module-name ...)))
+            "\n")])
+       (syntax/loc stx
+         (begin
+           
+           ;; Compile-time code: record the Javascript implementation here.
+           ;; Also, record that any references to the racket-module name
+           ;; should be redirected to this module.
+           (begin-for-syntax
+             (let* ([this-module 
+                     (variable-reference->resolved-module-path
+                      (#%variable-reference))]
+                    [key (resolved-module-path-name this-module)])
+               (record-redirection! (#%datum . resolved-racket-module-name)
+                                    key)
+               (record-javascript-implementation! key (#%datum . impl))))
+
+           (require racket-module-name)
+           (provide (all-from-out racket-module-name)))))]))
+
+
+(provide declare-conditional-implementation
+         (rename-out [#%plain-module-begin #%module-begin]))

lang/js-conditional/query.rkt

@@ -0,0 +1,51 @@
+#lang racket/base
+
+(require racket/contract
+         racket/runtime-path
+         syntax/modresolve)
+
+
+(provide/contract [query (module-path? . -> . string?)]
+                  [has-javascript-implementation? (module-path? . -> . boolean?)]
+                  
+                  [redirected? (path? . -> . boolean?)]
+                  [follow-redirection (path? . -> . path?)])
+
+(define-runtime-path record.rkt "record.rkt")
+(define ns (make-base-empty-namespace))
+
+;; query: module-path -> string?
+;; Given a module, see if it's implemented via Javascript.
+(define (query a-module-path)
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
+    (parameterize ([current-namespace ns])
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      ((dynamic-require-for-syntax record.rkt 'lookup-javascript-implementation) resolved-path))))
+
+
+;; has-javascript-implementation?:  module-path -> boolean
+(define (has-javascript-implementation? a-module-path)  
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
+    (parameterize ([current-namespace ns])
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      ((dynamic-require-for-syntax record.rkt 'has-javascript-implementation?) resolved-path))))
+  
+
+
+;; redirected? path -> boolean
+(define (redirected? a-module-path)
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
+    (parameterize ([current-namespace ns])
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (path? ((dynamic-require-for-syntax record.rkt 'follow-redirection)
+              resolved-path)))))
+
+
+;; follow-redirection: module-path -> path
+(define (follow-redirection a-module-path)
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
+    (parameterize ([current-namespace ns])
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      ((dynamic-require-for-syntax record.rkt 'follow-redirection)
+       resolved-path))))
+

lang/js-conditional/record.rkt

@@ -0,0 +1,62 @@
+#lang racket/base
+
+(provide record-javascript-implementation!
+         has-javascript-implementation?
+         lookup-javascript-implementation
+         
+         record-redirection!
+         follow-redirection)
+
+
+(define-struct record (path impl))
+(define records '())
+
+(define-struct redirection (from to))
+(define redirections '())
+
+;; record-javascript-implementation!: path string -> void
+(define (record-javascript-implementation! a-path an-impl)
+  (set! records (cons (make-record a-path an-impl)
+                      records)))
+
+;; has-javascript-implementation?: path -> boolean
+(define (has-javascript-implementation? a-path)
+  (let loop ([lst records])
+    (cond
+      [(null? lst)
+       #f]
+      [(equal? a-path (record-path (car lst)))
+       #t]
+      [else
+       (loop (cdr lst))])))
+
+
+;; find: path (listof record) -> record
+(define (find path lst)
+  (cond
+    [(null? lst)
+     (error 'find "Couldn't find ~s" path)]
+    [(equal? path (record-path (car lst)))
+     (car lst)]
+    [else
+     (find path (cdr lst))]))
+
+
+;; lookup-javascript-implementation: path -> module-path
+(define (lookup-javascript-implementation a-path)
+  (record-impl (find a-path records)))
+
+
+(define (record-redirection! from to)
+  (set! redirections (cons (make-redirection from to) redirections)))
+
+
+(define (follow-redirection a-path)
+  (let loop ([redirections redirections])
+    (cond
+      [(null? redirections)
+       #f]
+      [(equal? (redirection-from (car redirections)) a-path)
+       (redirection-to (car redirections))]
+      [else
+       (loop (cdr redirections))])))

lang/js-impl/js-impl.rkt

@@ -0,0 +1,57 @@
+#lang racket/base
+
+;; Special language level where implementation is done in Javascript.
+
+(require (for-syntax racket/base)
+         (for-syntax racket/file)
+         (for-syntax syntax/modresolve)
+         (for-syntax "record.rkt"))
+
+
+(define-for-syntax (read-implementation a-module-path)
+  (let ([a-path (parameterize ([current-directory (or (current-load-relative-directory)
+                                                      (current-directory))])
+                  (resolve-module-path a-module-path #f))])
+    (file->string a-path)))
+    
+
+(define-syntax (require-js stx)
+  (syntax-case stx ()
+    [(_ path ...)
+     (andmap (compose string? syntax-e) (syntax->list #'(path ...)))
+     (with-syntax 
+         ([(impl ...) (map (compose read-implementation syntax-e)
+                           (syntax->list #'(path ...)))])
+       (syntax/loc stx
+         (begin
+           (begin-for-syntax
+             (let* ([this-module (variable-reference->resolved-module-path (#%variable-reference))]
+                    [key (resolved-module-path-name this-module)])
+               (record-implementations! key (list (#%datum . impl) ...))))
+           (void))))]))
+
+                                       
+(define-syntax (-provide stx)
+  (syntax-case stx ()
+    [(_ name ...)
+     (andmap (compose symbol? syntax-e) (syntax->list #'(name ...)))
+     (syntax/loc stx
+       (begin
+         (begin-for-syntax
+           (let* ([this-module (variable-reference->resolved-module-path (#%variable-reference))]
+                    [key (resolved-module-path-name this-module)])
+               (record-exports! key (list (#%datum . name) ...))))
+         (provide name ...)
+         (begin (define name (lambda args 
+                               (error (quote name) 
+                                      "Must be evaluated within Javascript"))) ...)))]))
+
+
+
+
+           
+(provide require-js
+         require
+	 planet
+	 (rename-out (-provide provide)
+                     (#%plain-module-begin #%module-begin)))

lang/js-impl/query.rkt

@@ -0,0 +1,39 @@
+#lang racket/base
+
+(require racket/contract
+         racket/runtime-path
+         racket/list
+         syntax/modresolve)
+
+
+(define-struct js-module (impls exports))
+
+(provide/contract [query
+                   (module-path? . -> . (or/c js-module? false/c))]
+                  [struct js-module ([impls (listof string?)]
+                                     [exports (listof symbol?)])])
+
+
+
+
+(define-runtime-path record.rkt "record.rkt")
+(define ns (make-base-empty-namespace))
+
+
+
+;; query: module-path -> (listof string)
+;; Given a module, see if it's implemented via Javascript.
+(define (query a-module-path)
+  (let ([resolved-path (resolve-module-path a-module-path #f)])
+    (parameterize ([current-namespace ns])
+      (dynamic-require a-module-path (void)) ;; get the compile-time code running.
+      (let ([result
+             ((dynamic-require-for-syntax record.rkt 'lookup-implementations) resolved-path)])
+        (cond
+          [(empty? result)
+           #f]
+          [else
+           (make-js-module result
+                           ((dynamic-require-for-syntax record.rkt 'lookup-exports) resolved-path))])))))
+
+  

lang/js-impl/record.rkt

@@ -0,0 +1,61 @@
+#lang racket/base
+
+(provide record-implementations! 
+         record-exports!
+         lookup-implementations
+         lookup-exports)
+
+(define-struct record (path impls))
+(define-struct export (path exports))
+
+(define records '())
+(define exports '())
+
+;; record!: path (listof string) -> void
+(define (record-implementations! a-path impls)
+  (set! records (cons (make-record a-path impls)
+                      records)))
+
+
+;; record-exports!: path (listof symbol) -> void
+(define (record-exports! a-path export-names)
+  (set! exports (cons (make-export a-path export-names)
+                      exports)))
+
+
+(define (my-foldl f acc lst)
+  (cond
+    [(null? lst)
+     acc]
+    [else
+     (my-foldl f (f (car lst) acc) (cdr lst))]))
+                    
+
+(define (my-filter f lst)
+  (cond
+    [(null? lst)
+     '()]
+    [(f (car lst))
+     (cons (car lst) (my-filter f (cdr lst)))]
+    [else
+     (my-filter f (cdr lst))]))
+
+
+;; lookup-implementations: path -> (listof string)
+(define (lookup-implementations a-path)
+  (my-foldl (lambda (a-record perms)
+           (append (record-impls a-record) perms))
+         '()
+         (my-filter (lambda (a-record)
+                   (equal? a-path (record-path a-record)))
+                 records)))
+
+
+;; lookup-exports: path -> (listof symbol)
+(define (lookup-exports a-path)
+  (my-foldl (lambda (an-export exports)
+           (append (export-exports an-export) exports))
+         '()
+         (my-filter (lambda (an-export)
+                   (equal? a-path (export-path an-export)))
+                 exports)))