mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

refactor `raco pollen ...` command handling

Browse Source
pull/84/head
Matthew Butterick 10 years ago
parent 85182e22a3
commit 26762fb79c
3 changed files with 100 additions and 114 deletions
Show Stats Download Patch File Download Diff File

167
command.rkt
Unescape Escape View File

@ -1,15 +1,42 @@
#lang racket/base #lang racket/base
(require pollen/world sugar/coerce) (require pollen/world)
(provide (all-defined-out))
(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) (define (very-nice-path x)
(local-require sugar/coerce)
(path->complete-path (simplify-path (cleanse-path (->path x))))) (path->complete-path (simplify-path (cleanse-path (->path x)))))
(define (handle-test) (define (handle-test)
`(displayln "raco pollen is installed correctly")) (displayln "raco pollen is installed correctly"))
(define (handle-help) (define (handle-help)
`(displayln (format "Pollen commands: (displayln (format "Pollen commands:
help show this message help show this message
start [dir] [port] starts project server in dir (default is current dir) start [dir] [port] starts project server in dir (default is current dir)
(default port is ~a) (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 copy project to desktop without source files
publish [dir] [dest] copy project in dir to dest without source files publish [dir] [dest] copy project in dir to dest without source files
(warning: overwrites existing dest dir) (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) (define (handle-version)
`(displayln ,(world:current-pollen-version))) (displayln (world:current-pollen-version)))
(define (handle-render path-args) (define (handle-render path-args)
`(begin (local-require pollen/pagetree pollen/render pollen/file sugar/coerce racket/string)
(require pollen/render pollen/world pollen/file sugar pollen/pagetree racket/list pollen/command racket/string) (parameterize ([current-directory (world:current-project-root)])
(parameterize ([current-directory (world:current-project-root)]) (define first-arg (car path-args))
(define path-args ',path-args) (if (directory-exists? first-arg)
(define first-arg (car path-args)) (let ([dir first-arg]) ; now we know it's a dir
(if (directory-exists? first-arg) (parameterize ([current-directory dir]
(let ([dir first-arg]) ; now we know it's a dir [world:current-project-root dir])
(parameterize ([current-directory dir] (define preprocs (filter preproc-source? (directory-list dir)))
[world:current-project-root dir]) (define static-pagetrees (filter pagetree-source? (directory-list dir)))
(define preprocs (filter preproc-source? (directory-list dir))) ;; if there are no static pagetrees, use make-project-pagetree
(define static-pagetrees (filter pagetree-source? (directory-list dir))) ;; (which will synthesize a pagetree if needed, which includes all sources)
;; if there are no static pagetrees, use make-project-pagetree (define preprocs-and-static-pagetrees (append preprocs static-pagetrees))
;; (which will synthesize a pagetree if needed, which includes all sources) (define batch-to-render
(define preprocs-and-static-pagetrees (append preprocs static-pagetrees)) (map very-nice-path
(define batch-to-render (cond
(map very-nice-path [(null? preprocs-and-static-pagetrees)
(cond (displayln (format "Rendering generated pagetree for directory ~a" dir))
[(empty? preprocs-and-static-pagetrees) (cdr (make-project-pagetree dir))]
(displayln (format "Rendering generated pagetree for directory ~a" dir)) [else
(cdr (make-project-pagetree dir))] (displayln (format "Rendering preproc & pagetree files in directory ~a" dir))
[else preprocs-and-static-pagetrees])))
(displayln (format "Rendering preproc & pagetree files in directory ~a" dir)) (apply render-batch batch-to-render)))
preprocs-and-static-pagetrees]))) (begin ; first arg is a file
(apply render-batch batch-to-render))) (displayln (format "Rendering ~a" (string-join (map ->string path-args) " ")))
(begin ; first arg is a file (apply render-batch path-args)))))
(displayln (format "Rendering ~a" (string-join (map ->string path-args) " ")))
(apply render-batch path-args))))))
(define (handle-start directory [port #f]) (define (handle-start directory [port #f])
(if (not (directory-exists? directory)) (if (not (directory-exists? directory))
(error (format "~a is not a directory" directory)) (error (format "~a is not a directory" directory))
`(begin (parameterize ([world:current-project-root directory]
(require pollen/server pollen/world) [world:current-server-port (or port world:default-port)])
(parameterize ([world:current-project-root ,directory] ((dynamic-require 'pollen/server 'start-server)))))
,@(if port (list `(world:current-server-port ,port)) null))
(start-server)))))
(define (handle-publish directory rest-args arg-command-name) (define (handle-publish directory rest-args arg-command-name)
(define target-path (or (local-require racket/file racket/list pollen/file)
(and rest-args (not (null? rest-args)) (path->complete-path (string->path (car rest-args)))) (define target-path
(build-path (find-system-path 'desk-dir) (string->path (if (equal? arg-command-name "clone") "clone" (world:current-publish-directory-name)))))) (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 (define source-dir (simplify-path directory))
(require racket/file pollen/file racket/list) (when (not (directory-exists? source-dir))
(define (delete-it path) (error 'publish (format "source directory ~a does not exist" source-dir)))
(cond (define target-dir (simplify-path target-path))
[(directory-exists? path) (delete-directory/files path)] (when (source-dir . contains-directory? . target-dir)
[(file-exists? path) (delete-file path)])) (error 'publish "aborted because target directory for publishing (~a) can't be inside source directory (~a)" target-dir source-dir))
(define (contains-directory? possible-superdir possible-subdir) (when (target-dir . contains-directory? . source-dir)
(define (has-prefix? xs prefix) (error 'publish "aborted because target directory for publishing (~a) can't contain source directory (~a)" target-dir source-dir))
(and (>= (length xs) (length prefix)) (when (equal? target-dir (current-directory))
(andmap equal? prefix (take xs (length prefix))))) (error 'publish "aborted because target directory for publishing (~a) can't be the same as current directory (~a)" target-dir (current-directory)))
((explode-path possible-subdir) . has-prefix? . (explode-path possible-superdir))) (displayln "publishing ...")
(define source-dir (simplify-path ,directory)) (when (directory-exists? target-dir)
(when (not (directory-exists? source-dir)) (error 'publish (format "source directory ~a does not exist" source-dir))) (delete-directory/files target-dir))
(define target-dir (simplify-path ,target-path)) (copy-directory/files source-dir target-dir)
(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)) (for-each delete-it (find-files pollen-related-file? target-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)) (displayln (format "completed to ~a" target-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) (define (handle-unknown command)
`(if (regexp-match #rx"(shit|fuck)" ,command) (if (regexp-match #rx"(shit|fuck)" command)
(displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")]) (displayln (let ([responses '("Cursing at free software? Really?" "How uncouth." "Same to you, buddy.")])
(list-ref responses (random (length responses))))) (list-ref responses (random (length responses)))))
(displayln (format "unknown command ~a" ,command)))) (displayln (format "unknown command ~a" command))))

4
info.rkt
Unescape Escape View File

@ -5,6 +5,6 @@
(define build-deps '("plot-gui-lib" "scribble-lib" "racket-doc" "plot-doc" "scribble-doc" "slideshow-doc" "web-server-doc")) (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 update-implies '("txexpr" "sugar"))
(define scribblings '(("scribblings/pollen.scrbl" (multi-page)))) (define scribblings '(("scribblings/pollen.scrbl" (multi-page))))
(define raco-commands '(("pollen" (submod pollen/raco main) "issue Pollen command" #f))) (define raco-commands '(("pollen" (submod pollen/command raco) "issue Pollen command" #f)))
(define compile-omit-paths '("tests" "raco.rkt")) (define compile-omit-paths '("tests"))
(define test-omit-paths '("tests/data")) (define test-omit-paths '("tests/data"))

43
raco.rkt
Unescape Escape View File

@ -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))
Write Preview
Loading…
Cancel
Save