From 26762fb79cab4e963706bd44d600223dac9c92f1 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 4 Jul 2015 16:35:17 -0700 Subject: [PATCH] refactor `raco pollen ...` command handling --- command.rkt | 167 ++++++++++++++++++++++++++++++---------------------- info.rkt | 4 +- raco.rkt | 43 -------------- 3 files changed, 100 insertions(+), 114 deletions(-) delete mode 100644 raco.rkt diff --git a/command.rkt b/command.rkt index a7b08ee..a955f66 100644 --- a/command.rkt +++ b/command.rkt @@ -1,15 +1,42 @@ #lang racket/base -(require pollen/world sugar/coerce) -(provide (all-defined-out)) +(require pollen/world) + +(module+ raco + (define command-name (with-handlers ([exn:fail? (λ _ #f)]) + (vector-ref (current-command-line-arguments) 0))) + (dispatch command-name)) + +(define (dispatch command-name) + (local-require racket/path) + (define (get-first-arg-or-current-dir) + (normalize-path + (with-handlers ([exn:fail? (λ(exn) (current-directory))]) + ;; incoming path argument is handled as described in docs for current-directory + (very-nice-path (vector-ref (current-command-line-arguments) 1))))) + (case command-name + [("test" "xyzzy") (handle-test)] + [(#f "help") (handle-help)] + [("start") (define port-arg + (with-handlers ([exn:fail? (λ _ #f)]) + (string->number (vector-ref (current-command-line-arguments) 2)))) + (handle-start (path->directory-path (get-first-arg-or-current-dir)) port-arg)] + [("render") (handle-render (cons (get-first-arg-or-current-dir) (map very-nice-path (cdr (vector->list (current-command-line-arguments))))))] + [("version") (handle-version)] + [("clone" "publish") (define rest-args + (with-handlers ([exn:fail? (λ _ #f)]) + (cddr (vector->list (current-command-line-arguments))))) + (handle-publish (get-first-arg-or-current-dir) rest-args command-name)] + [else (handle-unknown command-name)])) (define (very-nice-path x) + (local-require sugar/coerce) (path->complete-path (simplify-path (cleanse-path (->path x))))) (define (handle-test) - `(displayln "raco pollen is installed correctly")) + (displayln "raco pollen is installed correctly")) (define (handle-help) - `(displayln (format "Pollen commands: + (displayln (format "Pollen commands: help show this message start [dir] [port] starts project server in dir (default is current dir) (default port is ~a) @@ -19,83 +46,85 @@ render filename render filename only (can be source or output name) publish copy project to desktop without source files publish [dir] [dest] copy project in dir to dest without source files (warning: overwrites existing dest dir) -version print the version (~a)" ,(world:current-server-port) ,(world:current-pollen-version)))) +version print the version (~a)" (world:current-server-port) (world:current-pollen-version)))) (define (handle-version) - `(displayln ,(world:current-pollen-version))) + (displayln (world:current-pollen-version))) (define (handle-render path-args) - `(begin - (require pollen/render pollen/world pollen/file sugar pollen/pagetree racket/list pollen/command racket/string) - (parameterize ([current-directory (world:current-project-root)]) - (define path-args ',path-args) - (define first-arg (car path-args)) - (if (directory-exists? first-arg) - (let ([dir first-arg]) ; now we know it's a dir - (parameterize ([current-directory dir] - [world:current-project-root dir]) - (define preprocs (filter preproc-source? (directory-list dir))) - (define static-pagetrees (filter pagetree-source? (directory-list dir))) - ;; if there are no static pagetrees, use make-project-pagetree - ;; (which will synthesize a pagetree if needed, which includes all sources) - (define preprocs-and-static-pagetrees (append preprocs static-pagetrees)) - (define batch-to-render - (map very-nice-path - (cond - [(empty? preprocs-and-static-pagetrees) - (displayln (format "Rendering generated pagetree for directory ~a" dir)) - (cdr (make-project-pagetree dir))] - [else - (displayln (format "Rendering preproc & pagetree files in directory ~a" dir)) - preprocs-and-static-pagetrees]))) - (apply render-batch batch-to-render))) - (begin ; first arg is a file - (displayln (format "Rendering ~a" (string-join (map ->string path-args) " "))) - (apply render-batch path-args)))))) - + (local-require pollen/pagetree pollen/render pollen/file sugar/coerce racket/string) + (parameterize ([current-directory (world:current-project-root)]) + (define first-arg (car path-args)) + (if (directory-exists? first-arg) + (let ([dir first-arg]) ; now we know it's a dir + (parameterize ([current-directory dir] + [world:current-project-root dir]) + (define preprocs (filter preproc-source? (directory-list dir))) + (define static-pagetrees (filter pagetree-source? (directory-list dir))) + ;; if there are no static pagetrees, use make-project-pagetree + ;; (which will synthesize a pagetree if needed, which includes all sources) + (define preprocs-and-static-pagetrees (append preprocs static-pagetrees)) + (define batch-to-render + (map very-nice-path + (cond + [(null? preprocs-and-static-pagetrees) + (displayln (format "Rendering generated pagetree for directory ~a" dir)) + (cdr (make-project-pagetree dir))] + [else + (displayln (format "Rendering preproc & pagetree files in directory ~a" dir)) + preprocs-and-static-pagetrees]))) + (apply render-batch batch-to-render))) + (begin ; first arg is a file + (displayln (format "Rendering ~a" (string-join (map ->string path-args) " "))) + (apply render-batch path-args))))) (define (handle-start directory [port #f]) (if (not (directory-exists? directory)) (error (format "~a is not a directory" directory)) - `(begin - (require pollen/server pollen/world) - (parameterize ([world:current-project-root ,directory] - ,@(if port (list `(world:current-server-port ,port)) null)) - (start-server))))) + (parameterize ([world:current-project-root directory] + [world:current-server-port (or port world:default-port)]) + ((dynamic-require 'pollen/server 'start-server))))) (define (handle-publish directory rest-args arg-command-name) - (define target-path (or - (and rest-args (not (null? rest-args)) (path->complete-path (string->path (car rest-args)))) - (build-path (find-system-path 'desk-dir) (string->path (if (equal? arg-command-name "clone") "clone" (world:current-publish-directory-name)))))) + (local-require racket/file racket/list pollen/file) + (define target-path + (or + (and rest-args (not (null? rest-args)) (path->complete-path (string->path (car rest-args)))) + (build-path (find-system-path 'desk-dir) (string->path (if (equal? arg-command-name "clone") "clone" (world:current-publish-directory-name)))))) + + (define (delete-it path) + (cond + [(directory-exists? path) (delete-directory/files path)] + [(file-exists? path) (delete-file path)])) + + (define (contains-directory? possible-superdir possible-subdir) + (define (has-prefix? xs prefix) + (and (>= (length xs) (length prefix)) + (andmap equal? prefix (take xs (length prefix))))) + ((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir))) - `(begin - (require racket/file pollen/file racket/list) - (define (delete-it path) - (cond - [(directory-exists? path) (delete-directory/files path)] - [(file-exists? path) (delete-file path)])) - (define (contains-directory? possible-superdir possible-subdir) - (define (has-prefix? xs prefix) - (and (>= (length xs) (length prefix)) - (andmap equal? prefix (take xs (length prefix))))) - ((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir))) - (define source-dir (simplify-path ,directory)) - (when (not (directory-exists? source-dir)) (error 'publish (format "source directory ~a does not exist" source-dir))) - (define target-dir (simplify-path ,target-path)) - (when (source-dir . contains-directory? . target-dir) (error 'publish "aborted because target directory for publishing (~a) can't be inside source directory (~a)" target-dir source-dir)) - (when (target-dir . contains-directory? . source-dir) (error 'publish "aborted because target directory for publishing (~a) can't contain source directory (~a)" target-dir source-dir)) - (when (equal? target-dir (current-directory)) (error 'publish "aborted because target directory for publishing (~a) can't be the same as current directory (~a)" target-dir (current-directory))) - (displayln "publishing ...") - (when (directory-exists? target-dir) (delete-directory/files target-dir)) - (copy-directory/files source-dir target-dir) - (for-each delete-it (find-files pollen-related-file? target-dir)) - (displayln (format "completed to ~a" target-dir)))) + (define source-dir (simplify-path directory)) + (when (not (directory-exists? source-dir)) + (error 'publish (format "source directory ~a does not exist" source-dir))) + (define target-dir (simplify-path target-path)) + (when (source-dir . contains-directory? . target-dir) + (error 'publish "aborted because target directory for publishing (~a) can't be inside source directory (~a)" target-dir source-dir)) + (when (target-dir . contains-directory? . source-dir) + (error 'publish "aborted because target directory for publishing (~a) can't contain source directory (~a)" target-dir source-dir)) + (when (equal? target-dir (current-directory)) + (error 'publish "aborted because target directory for publishing (~a) can't be the same as current directory (~a)" target-dir (current-directory))) + (displayln "publishing ...") + (when (directory-exists? target-dir) + (delete-directory/files target-dir)) + (copy-directory/files source-dir target-dir) + (for-each delete-it (find-files pollen-related-file? target-dir)) + (displayln (format "completed to ~a" target-dir))) -(define (handle-else command) - `(if (regexp-match #rx"(shit|fuck)" ,command) - (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")]) - (list-ref responses (random (length responses))))) - (displayln (format "unknown command ~a" ,command)))) +(define (handle-unknown command) + (if (regexp-match #rx"(shit|fuck)" command) + (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")]) + (list-ref responses (random (length responses))))) + (displayln (format "unknown command ~a" command)))) diff --git a/info.rkt b/info.rkt index 602b602..dc5d382 100644 --- a/info.rkt +++ b/info.rkt @@ -5,6 +5,6 @@ (define build-deps '("plot-gui-lib" "scribble-lib" "racket-doc" "plot-doc" "scribble-doc" "slideshow-doc" "web-server-doc")) (define update-implies '("txexpr" "sugar")) (define scribblings '(("scribblings/pollen.scrbl" (multi-page)))) -(define raco-commands '(("pollen" (submod pollen/raco main) "issue Pollen command" #f))) -(define compile-omit-paths '("tests" "raco.rkt")) +(define raco-commands '(("pollen" (submod pollen/command raco) "issue Pollen command" #f))) +(define compile-omit-paths '("tests")) (define test-omit-paths '("tests/data")) diff --git a/raco.rkt b/raco.rkt deleted file mode 100644 index a996cbd..0000000 --- a/raco.rkt +++ /dev/null @@ -1,43 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base pollen/command racket/path)) - -;; Handle commands from raco - -(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 first-arg-or-current-dir - (with-handlers ([exn:fail? (λ(exn) (current-directory))]) - ;; incoming path argument is handled as described in - ;; docs for current-directory - (very-nice-path (vector-ref args 1)))) - -(define-for-syntax rest-args - (with-handlers ([exn:fail? (λ(exn) #f)]) - (cddr (vector->list (current-command-line-arguments))))) - -(define-for-syntax port-arg - (with-handlers ([exn:fail? (λ(exn) #f)]) - (string->number (vector-ref args 2)))) - -(define-for-syntax (command-error error-string) - `(displayln (string-append "Error: ", error-string))) - -;; we work in syntax layer because 'start' has to require pollen/server, -;; which is slow, and needs to happen at the top level. -(define-syntax (select-syntax-for-command stx) - (datum->syntax stx - ;; normalize-path happens here because it needs filesystem access - ;; (unlike cleanse-path or simplify-path) - (let ([first-arg-or-current-dir (normalize-path first-arg-or-current-dir)]) - (case arg-command-name - [("test" "xyzzy") (handle-test)] - [(#f "help") (handle-help)] - [("start") (handle-start (path->directory-path first-arg-or-current-dir) port-arg)] - [("render") (handle-render (cons first-arg-or-current-dir (map very-nice-path (cdr (vector->list (current-command-line-arguments))))))] - [("version") (handle-version)] - [("clone" "publish") (handle-publish first-arg-or-current-dir rest-args arg-command-name)] - [else (handle-else arg-command-name)])))) - -(module+ main - (select-syntax-for-command))