From 64b1d531bbfecbc08395e147edeee256e6b04823 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 20 Feb 2014 12:01:09 -0800 Subject: [PATCH] streamline world --- lang/inner-lang-helper.rkt | 65 ++++++++++++++++++++++++++++++++++++++ lang/lang-helper.rkt | 49 ---------------------------- main.rkt | 42 ++++++++++++++---------- project-requires.rkt | 3 +- server-routes.rkt | 8 ----- server.rkt | 3 ++ world.rkt | 10 ++---- 7 files changed, 98 insertions(+), 82 deletions(-) create mode 100644 lang/inner-lang-helper.rkt delete mode 100644 lang/lang-helper.rkt diff --git a/lang/inner-lang-helper.rkt b/lang/inner-lang-helper.rkt new file mode 100644 index 0000000..551d5af --- /dev/null +++ b/lang/inner-lang-helper.rkt @@ -0,0 +1,65 @@ +#lang racket/base +(require (for-syntax racket/base)) + +(require racket/contract/region) + +(provide (all-defined-out) (all-from-out racket/contract/region)) + +;; A place to stash functions that don't change between compiles of Pollen files. + +;; duplicate of contents of project-require.rkt. +;; Goes faster if it's not in a separate module. +;; todo: use include? But this one has to be available as syntax +;; todo: get rid of magic value +(define-for-syntax (project-require-file? path) + (define path-string (path->string path)) + (equal? (substring path-string (- (string-length path-string) 3) (string-length path-string)) "rkt")) + +;; list of all eligible requires in project require directory +(define-for-syntax (get-project-require-files) + (define extras-directory (build-path (current-directory) "pollen-require")) + (and (directory-exists? extras-directory) + ;; #:build? option returns complete paths (instead of just file names) + (let ([files (filter project-require-file? (directory-list extras-directory #:build? #t))]) + (and (not (equal? '() files)) files)))) + +(define-for-syntax (put-file-in-require-form file) + `(file ,(path->string file))) + +(define-for-syntax (do-project-require-file-syntax stx #:provide? [provide? #f]) + (define project-require-files (get-project-require-files)) + (if project-require-files + (let ([files-in-require-form (map put-file-in-require-form project-require-files)]) + (datum->syntax stx `(begin + (require ,@files-in-require-form) + ,@(if provide? + (list `(provide (all-from-out ,@files-in-require-form))) + '())))) + ; if no files to import, do nothing + #'(begin))) + +(define-syntax (require-and-provide-project-require-files stx) + (do-project-require-file-syntax stx #:provide? #t)) + +(define-syntax (require-project-require-files stx) + (do-project-require-file-syntax stx)) + +(define-syntax (get-here-path stx) + (datum->syntax stx + '(begin + ;; This macro might be used in an expression context, + ;; so we use let, not define. + (let* ([ccr (current-contract-region)] ; trick for getting current module name + [here-path (cond + ;; if contract-region is called from within submodule, + ;; you get a list + ;; in which case, just grab the path from the front + [(list? ccr) (car ccr)] + ;; file isn't yet saved in drracket + ;; 'pollen-lang-module name is applied by reader + [(equal? 'pollen-lang-module ccr) 'nowhere] + [else ccr])]) + (path->string here-path))))) + + + diff --git a/lang/lang-helper.rkt b/lang/lang-helper.rkt deleted file mode 100644 index 820f943..0000000 --- a/lang/lang-helper.rkt +++ /dev/null @@ -1,49 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base pollen/project-requires)) - -(require racket/contract/region) - -(provide (all-defined-out) (all-from-out racket/contract/region)) - - - -(define-for-syntax (put-file-in-require-form file) - `(file ,(path->string file))) - -(define-for-syntax (do-project-require-file-syntax stx #:provide? [provide? #f]) - (define project-require-files (get-project-require-files)) - (if project-require-files - (let ([files-in-require-form (map put-file-in-require-form project-require-files)]) - (datum->syntax stx `(begin - (require ,@files-in-require-form) - ,@(if provide? - (list `(provide (all-from-out ,@files-in-require-form))) - '())))) - ; if no files to import, do nothing - #'(begin))) - -(define-syntax (require-and-provide-project-require-files stx) - (do-project-require-file-syntax stx #:provide? #t)) - -(define-syntax (require-project-require-files stx) - (do-project-require-file-syntax stx)) - -(define-syntax (get-here-path stx) - (datum->syntax stx - '(begin - ;; This macro might be used in an expression context, - ;; so we use let, not define. - (let* ([ccr (current-contract-region)] ; trick for getting current module name - [here-path (cond - ;; if contract-region is called from within submodule, - ;; you get a list - ;; in which case, just grab the path from the front - [(list? ccr) (car ccr)] - ;; file isn't yet saved in drracket - ;; 'pollen-lang-module name is applied by reader - [(equal? 'pollen-lang-module ccr) 'nowhere] - [else ccr])]) - (path->string here-path))))) - - - diff --git a/main.rkt b/main.rkt index dedb943..1c06dad 100644 --- a/main.rkt +++ b/main.rkt @@ -12,18 +12,20 @@ (λ(x) x) ; post-process function () ; prepended exprs - (require pollen/lang/lang-helper) - (require-and-provide-project-require-files) + (require pollen/lang/inner-lang-helper) + (require-and-provide-project-require-files) ; only works if current-directory is set correctly ;; Change behavior of undefined identifiers with #%top (require pollen/top) (provide (all-from-out pollen/top)) ;; Build 'inner-here-path and 'inner-here - (define inner-here-path (get-here-path)) (require (only-in racket/path find-relative-path)) (require (only-in pollen/world PROJECT_ROOT)) - (define inner-here (path->string (path-replace-suffix (find-relative-path PROJECT_ROOT inner-here-path) ""))) + (define (here-path->here here-path) + (path->string (path-replace-suffix (find-relative-path PROJECT_ROOT here-path) ""))) + (define inner-here-path (get-here-path)) + (define inner-here (here-path->here inner-here-path)) (provide (all-defined-out)) @@ -31,24 +33,30 @@ (require 'inner) - ;; Split out the metas. - (require txexpr) - (define main-txexpr `(placeholder-root ,@(cdr main-raw))) ;; cdr strips initial linebreak - (define is-meta-element? (λ(x) (and (txexpr? x) (equal? 'meta (car x))))) - (define-values (main-without-metas meta-elements) - (splitf-txexpr main-txexpr is-meta-element?)) - (define meta-element->assoc (λ(x) (cons (cadr x) (caddr x)))) - ;; Prepend 'here-path and 'here as metas so they can be overridden by metas embedded in source. - (define metas (make-hash (map meta-element->assoc (cons `(meta "here-path" ,inner-here-path) - (cons `(meta "here" ,inner-here) meta-elements))))) + ;; Split out the metas. + (require (only-in racket/path find-relative-path)) + (require (only-in pollen/world PROJECT_ROOT)) + (define (here-path->here here-path) + (path->string (path-replace-suffix (find-relative-path PROJECT_ROOT here-path) ""))) + (require txexpr) + (define (split-metas-to-hash tx) + ;; return tx without metas, and meta hash + (define is-meta-element? (λ(x) (and (txexpr? x) (equal? 'meta (car x))))) + (define-values (main-without-metas meta-elements) + (splitf-txexpr tx is-meta-element?)) + (define meta-element->assoc (λ(x) (cons (cadr x) (caddr x)))) + (define metas (make-hash (map meta-element->assoc meta-elements))) + (values main-without-metas metas)) + (define main-txexpr `(placeholder-root ,@(cons `(meta "here" ,inner-here) (cons `(meta "here-path" ,inner-here-path) + (cdr main-raw))))) ;; cdr strips initial linebreak + (define-values (main-without-metas metas) (split-metas-to-hash main-txexpr)) - ;; set up the 'main export - (require pollen/decode) + (require pollen/decode pollen/world) (require (only-in racket/list filter-not)) (define here-ext (car (regexp-match #px"\\w+$" inner-here-path))) - (define wants-decoder? (member here-ext (list "pd" "ptree"))) + (define wants-decoder? (member here-ext (map to-string DECODABLE_EXTENSIONS))) ;(print (cdr main-without-metas)) (define main (apply (cond [(equal? here-ext "ptree") (λ xs (decode (cons 'ptree-root xs) diff --git a/project-requires.rkt b/project-requires.rkt index 8f7bddc..bdedc97 100644 --- a/project-requires.rkt +++ b/project-requires.rkt @@ -1,4 +1,5 @@ #lang racket/base +(require "world.rkt") (provide (all-defined-out)) (define (project-require-file? path) @@ -7,7 +8,7 @@ ;; list of all eligible requires in project require directory (define (get-project-require-files) - (define extras-directory (build-path (current-directory) "pollen-require")) + (define extras-directory (build-path (current-directory) EXTRAS_DIR)) (and (directory-exists? extras-directory) ;; #:build? option returns complete paths (instead of just file names) (let ([files (filter project-require-file? (directory-list extras-directory #:build? #t))]) diff --git a/server-routes.rkt b/server-routes.rkt index fb13cc7..78bed28 100644 --- a/server-routes.rkt +++ b/server-routes.rkt @@ -234,7 +234,6 @@ (request? . -> . response?) (define error-text (format "route-404: Can't find ~a" (->string (req->path req)))) (message error-text) - ;`(html ,(slurp (build-path SERVER_EXTRAS_DIR "404.html"))) (response/xexpr `(html ,error-text))) @@ -245,10 +244,3 @@ (format-as-code (~v (file->xexpr path)))) (define route-xexpr (route-wrapper xexpr)) - -(module+ main - (parameterize ([current-directory (build-path (current-directory) "foobar")]) - (reset-project-root) - ; (message PROJECT_ROOT) - ; (make-binary-info-page (build-path "foo.gif")) - )) \ No newline at end of file diff --git a/server.rkt b/server.rkt index 3dffd18..0428575 100755 --- a/server.rkt +++ b/server.rkt @@ -23,6 +23,9 @@ (message "Ready to rock") +(define MODULE_ROOT (apply build-path (drop-right (explode-path (current-contract-region)) 1))) +(define SERVER_EXTRAS_DIR (build-path MODULE_ROOT "pollen-server-extras")) + (serve/servlet pollen-servlet #:port SERVER_PORT #:listen-ip #f diff --git a/world.rkt b/world.rkt index 8c61157..1b20b20 100644 --- a/world.rkt +++ b/world.rkt @@ -1,5 +1,4 @@ #lang racket/base -(require racket/list racket/contract) ;; todo: how to make project- or user-specific prefs @@ -8,8 +7,9 @@ (define POLLEN_VERSION "0.001") (define PREPROC_SOURCE_EXT 'p) -(define DECODER_SOURCE_EXT 'pd) +(define DECODER_SOURCE_EXT 'pm) (define PTREE_SOURCE_EXT 'ptree) +(define DECODABLE_EXTENSIONS (list DECODER_SOURCE_EXT PTREE_SOURCE_EXT)) (define DEFAULT_PTREE "main.ptree") (define PTREE_ROOT_NODE 'ptree-root) @@ -41,15 +41,11 @@ (define COMMAND_FILE "polcom") -(require sugar) (define RESERVED_PATHS - (map ->path (list COMMAND_FILE EXTRAS_DIR "poldash.css" "compiled"))) + (map string->path (list COMMAND_FILE (path->string EXTRAS_DIR) "poldash.css" "compiled"))) (define PROJECT_ROOT (current-directory)) -(define (reset-project-root) (set! PROJECT_ROOT (current-directory))) -(define MODULE_ROOT (apply build-path (drop-right (explode-path (current-contract-region)) 1))) -(define SERVER_EXTRAS_DIR (build-path MODULE_ROOT "pollen-server-extras")) (define SERVER_PORT 8088)