diff --git a/lang/js-conditional/js-conditional.rkt b/lang/js-conditional/js-conditional.rkt new file mode 100644 index 0000000..150ddce --- /dev/null +++ b/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])) \ No newline at end of file diff --git a/lang/js-conditional/query.rkt b/lang/js-conditional/query.rkt new file mode 100644 index 0000000..ea8731a --- /dev/null +++ b/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)))) + diff --git a/lang/js-conditional/record.rkt b/lang/js-conditional/record.rkt new file mode 100644 index 0000000..54452ed --- /dev/null +++ b/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))]))) \ No newline at end of file diff --git a/lang/js-impl/js-impl.rkt b/lang/js-impl/js-impl.rkt new file mode 100644 index 0000000..06c69e7 --- /dev/null +++ b/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))) diff --git a/lang/js-impl/query.rkt b/lang/js-impl/query.rkt new file mode 100644 index 0000000..396956e --- /dev/null +++ b/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))]))))) + + diff --git a/lang/js-impl/record.rkt b/lang/js-impl/record.rkt new file mode 100644 index 0000000..0acf266 --- /dev/null +++ b/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))) \ No newline at end of file