You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
80 lines
4.5 KiB
Racket
80 lines
4.5 KiB
Racket
#lang racket/base
|
|
(require pollen/world)
|
|
(provide (all-defined-out))
|
|
|
|
(define (handle-test)
|
|
`(displayln "raco pollen is installed correctly"))
|
|
|
|
(define (handle-help)
|
|
`(displayln (format "Pollen commands:
|
|
help show this message
|
|
start [dir] [port] starts project server in dir (default is current dir)
|
|
(default port is ~a)
|
|
render [dir] [dest] render project in dir (default is current dir)
|
|
to dest (default is desktop)
|
|
render filename render filename only (can be source or output name)
|
|
clone copy project to desktop without source files" ,(world:current-server-port))))
|
|
|
|
(define (handle-render dir-or-path rest-args)
|
|
`(begin
|
|
(require pollen/render pollen/world pollen/file sugar pollen/pagetree racket/list)
|
|
(parameterize ([current-directory (world:current-project-root)])
|
|
(define dir-or-path ,dir-or-path)
|
|
(apply render-batch (map ->complete-path (if (not (directory-exists? dir-or-path))
|
|
(begin
|
|
(displayln (format "Rendering ~a" dir-or-path))
|
|
(cons dir-or-path ',rest-args))
|
|
(let ([dir dir-or-path]) ; now we know it's a dir
|
|
(displayln (format "Rendering preproc & pagetree files in directory ~a" 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 pagetrees (if (empty? static-pagetrees)
|
|
(list (make-project-pagetree dir))
|
|
static-pagetrees))
|
|
(append* preprocs pagetrees))))))))
|
|
|
|
|
|
(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)))))
|
|
|
|
|
|
(define (handle-clone directory rest-args)
|
|
(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 world:clone-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 'clone (format "source directory ~a does not exist" source-dir)))
|
|
(define target-dir (simplify-path ,target-path))
|
|
(when (source-dir . contains-directory? . target-dir) (error 'clone "aborted because target directory for cloning (~a) can't be inside source directory (~a)" target-dir source-dir))
|
|
(displayln "Cloning ...")
|
|
(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))))
|