From 5283b4b95848171798375746d6295d248e0e52df Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 27 Feb 2014 14:48:15 -0800 Subject: [PATCH] replace polcom with raco --- command.rkt | 46 +++++++++++++++++++++++++++++++++++++++ info.rkt | 3 ++- server.rkt | 62 ++++++++++++++++++++++++++++------------------------- 3 files changed, 81 insertions(+), 30 deletions(-) diff --git a/command.rkt b/command.rkt index 572ad16..7135443 100644 --- a/command.rkt +++ b/command.rkt @@ -1,6 +1,51 @@ #lang racket/base (require (for-syntax racket/base)) +;; Handle commands from raco + +;; arg 0 will be the command name +(define-for-syntax args (current-command-line-arguments)) +(define-for-syntax arg-command-name (with-handlers ([exn:fail? (λ(exn) #f)]) + (vector-ref args 0))) + +(define-for-syntax arg-project-directory + (if (> (vector-length args) 1) + (with-handlers ([exn:fail? (λ(exn) #f)]) + (let ([possible-path (path->complete-path (simplify-path (string->path (vector-ref args 1))))]) + possible-path)) + (current-directory))) + +(define-for-syntax (command-error error-string) + `(displayln (string-append "Error: ", error-string))) + +(define-syntax (just-a-hook-for-the-macro stx) + (if arg-command-name + (datum->syntax stx + (case arg-command-name + [("nothing") '(begin)] + [("test") `(displayln "All systems go")] + [("start") + (if (not (directory-exists? arg-project-directory)) + (command-error (format "~a is not a directory" arg-project-directory)) + `(begin + (require pollen/server pollen/world) + (parameterize ([world:current-project-root ,arg-project-directory]) + (start-server))))] + [else (if (regexp-match #rx"(shit|fuck)" arg-command-name) + (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")]) + (list-ref responses (random (length responses))))) + (command-error (format "unknown command ~a" arg-command-name)))])) + #'(begin))) + +(just-a-hook-for-the-macro) + + + +#| + +#lang racket/base +(require (for-syntax racket/base)) + ;; todo: add command to check validity of installation (require (for-syntax sugar "world.rkt")) @@ -66,3 +111,4 @@ polcom [filename] (renders individual file)")] (handle-pollen-command) +|# \ No newline at end of file diff --git a/info.rkt b/info.rkt index 66a7791..211a344 100644 --- a/info.rkt +++ b/info.rkt @@ -1,4 +1,5 @@ #lang info (define collection "pollen") (define scribblings '(("scribblings/pollen.scrbl" ()))) -(define deps '("txexpr" "sugar")) \ No newline at end of file +(define deps '("txexpr" "sugar")) +(define raco-commands '(("pollen" pollen/command "issue Pollen command" #f))) diff --git a/server.rkt b/server.rkt index 16d4a72..14afd70 100755 --- a/server.rkt +++ b/server.rkt @@ -7,33 +7,37 @@ "file-tools.rkt" "cache.rkt") -(define-values (pollen-servlet _) - (dispatch-rules - [((string-arg) ... (? ptree-source?)) route-dashboard] - [((string-arg) ... "in" (string-arg)) route-in] - [((string-arg) ... "out" (string-arg)) route-out] - [((string-arg) ... "xexpr" (string-arg)) route-xexpr] - [else route-default])) +(provide start-server) -(message (format "Welcome to Pollen ~a" world:pollen-version) (format "(Racket ~a)" (version))) -(message (format "Project root is ~a" (world:current-project-root))) - -(define server-name (format "http://localhost:~a" world:server-port)) -(message (format "Project server is ~a" server-name) "(Ctrl-C to exit)") -(message (format "Project dashboard is ~a/~a" server-name world:dashboard-name)) - -(message "Ready to rock") - -(world:current-module-root (apply build-path (drop-right (explode-path (current-contract-region)) 1))) -(world:current-server-extras-path (build-path (world:current-module-root) "server-extras")) - -(parameterize ([world:current-module-root (world:current-module-root)] - [world:current-server-extras-path (world:current-server-extras-path)] - [current-cache (make-cache)]) - (serve/servlet pollen-servlet - #:port world:server-port - #:listen-ip #f - #:servlet-regexp #rx"" ; respond to top level - #:command-line? #t - #:file-not-found-responder route-404 - #:extra-files-paths (list (world:current-server-extras-path) (world:current-project-root)))) \ No newline at end of file +(define (start-server) + + (define-values (pollen-servlet _) + (dispatch-rules + [((string-arg) ... (? ptree-source?)) route-dashboard] + [((string-arg) ... "in" (string-arg)) route-in] + [((string-arg) ... "out" (string-arg)) route-out] + [((string-arg) ... "xexpr" (string-arg)) route-xexpr] + [else route-default])) + + (message (format "Welcome to Pollen ~a" world:pollen-version) (format "(Racket ~a)" (version))) + (message (format "Project root is ~a" (world:current-project-root))) + + (define server-name (format "http://localhost:~a" world:server-port)) + (message (format "Project server is ~a" server-name) "(Ctrl-C to exit)") + (message (format "Project dashboard is ~a/~a" server-name world:dashboard-name)) + + (message "Ready to rock") + + (world:current-module-root (apply build-path (drop-right (explode-path (current-contract-region)) 1))) + (world:current-server-extras-path (build-path (world:current-module-root) "server-extras")) + + (parameterize ([world:current-module-root (world:current-module-root)] + [world:current-server-extras-path (world:current-server-extras-path)] + [current-cache (make-cache)]) + (serve/servlet pollen-servlet + #:port world:server-port + #:listen-ip #f + #:servlet-regexp #rx"" ; respond to top level + #:command-line? #t + #:file-not-found-responder route-404 + #:extra-files-paths (list (world:current-server-extras-path) (world:current-project-root))))) \ No newline at end of file