From efbacd0f68103382f7845aa7911170eecad3dd0b Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 12 Aug 2011 15:41:53 -0400 Subject: [PATCH] resources keep a simple string key --- resource/compile-time.rkt | 35 ++++++++++++++------ resource/munge-path.rkt | 18 ++++++++++ resource/query.rkt | 70 +++++++++++++++++++++++++++++++++++++++ resource/record.rkt | 15 +++++++++ resource/structs.rkt | 2 +- 5 files changed, 128 insertions(+), 12 deletions(-) create mode 100644 resource/munge-path.rkt create mode 100644 resource/query.rkt create mode 100644 resource/record.rkt diff --git a/resource/compile-time.rkt b/resource/compile-time.rkt index 42e7528..62f9b1d 100644 --- a/resource/compile-time.rkt +++ b/resource/compile-time.rkt @@ -2,7 +2,9 @@ ;; Macros for recording the definition of resources in a program. (require (for-syntax racket/base racket/path - syntax/parse)) + syntax/parse + "munge-path.rkt" + "record.rkt")) (provide define-resource) @@ -14,13 +16,24 @@ (define-syntax (define-resource stx) (syntax-parse stx [(_ name:id path:str) - (with-syntax ([normal-path - (normalize-path (build-path - (or (current-load-relative-directory) - (current-directory)) - (syntax-e #'path)))]) - (syntax/loc stx - (begin (begin-for-syntax - (printf "compile time code executing; we need to save ~s\n" - normal-path)) - (define name (resource path)))))])) + (let* ([normal-path + (normalize-path (build-path + (or (current-load-relative-directory) + (current-directory)) + (syntax-e #'path)))] + [munged-path (munge-path normal-path)]) + (with-syntax ([normal-path normal-path] + [munged-path munged-path]) + (syntax/loc stx + (begin + ;; Compile time code: + (begin-for-syntax + (let* ([this-module + (variable-reference->resolved-module-path + (#%variable-reference))] + [key (resolved-module-path-name this-module)]) + ;(printf "Recording the resource ~a\n" normal-path) + (record-resource munged-path normal-path))) + + ;; Run time code + (define name (resource path munged-path))))))])) diff --git a/resource/munge-path.rkt b/resource/munge-path.rkt new file mode 100644 index 0000000..6ae7b32 --- /dev/null +++ b/resource/munge-path.rkt @@ -0,0 +1,18 @@ +#lang racket/base +(require net/base64 + file/md5) + +(provide munge-path) + +;; munge-path: path -> string +;; +;; Given a path, gives a munged base path string. +(define (munge-path a-path) + (define encoding-prefix (let ([op (open-output-string)]) + (base64-encode-stream (open-input-bytes + (md5 (path->string (build-path a-path)))) + op + "") + (get-output-string op))) + (define-values (base path dir?) (split-path a-path)) + (string-append encoding-prefix "_" (path->string path))) diff --git a/resource/query.rkt b/resource/query.rkt new file mode 100644 index 0000000..e093022 --- /dev/null +++ b/resource/query.rkt @@ -0,0 +1,70 @@ +#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?)] + [collect-redirections-to (path? . -> . (listof path?))] + + [lookup-module-requires (path? . -> . (listof 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)))) + + + +;; collect-redirections-to: module-path -> (listof path) +(define (collect-redirections-to 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 'collect-redirections-to) + resolved-path)))) + + +(define (lookup-module-requires 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-module-requires) resolved-path)))) diff --git a/resource/record.rkt b/resource/record.rkt new file mode 100644 index 0000000..f9b2c5c --- /dev/null +++ b/resource/record.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require racket/port) +(provide record-resource) + + +(define-struct record (key resource-path bytes)) +(define records '()) + + +;; record-javascript-implementation!: path a-resource-path -> void +(define (record-resource a-key a-resource-path) + (set! records (cons (make-record a-key + a-resource-path + (call-with-input-file a-resource-path port->bytes)) + records))) diff --git a/resource/structs.rkt b/resource/structs.rkt index 6432f1b..854777b 100644 --- a/resource/structs.rkt +++ b/resource/structs.rkt @@ -3,4 +3,4 @@ (provide (all-defined-out)) -(struct resource (path)) +(struct resource (path key))