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

91
command.rkt
Unescape Escape View File

@ -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,18 +46,16 @@ 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)
(local-require pollen/pagetree pollen/render pollen/file sugar/coerce 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
@ -44,7 +69,7 @@ version print the version (~a)" ,(world:current-server-port) ,(wo
(define batch-to-render
(map very-nice-path
(cond
[(empty? preprocs-and-static-pagetrees)
[(null? preprocs-and-static-pagetrees)
(displayln (format "Rendering generated pagetree for directory ~a" dir))
(cdr (make-project-pagetree dir))]
[else
@ -53,49 +78,53 @@ version print the version (~a)" ,(world:current-server-port) ,(wo
(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))))))
(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
(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))))))
`(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)))
(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))
(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))))
(displayln (format "completed to ~a" target-dir)))
(define (handle-else command)
`(if (regexp-match #rx"(shit|fuck)" ,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))))
(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 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"))

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