From 3be69c2c54fda96c125f2f4727165f541a7a4958 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 10 Jan 2014 14:25:03 -0800 Subject: [PATCH] make setup object based --- setup.rkt | 143 ++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 113 insertions(+), 30 deletions(-) diff --git a/setup.rkt b/setup.rkt index 4c194e6..69a0dd5 100644 --- a/setup.rkt +++ b/setup.rkt @@ -1,10 +1,49 @@ #lang racket/base -(require racket/system racket/port racket/file racket/string racket/date) +(require racket/system racket/port racket/file + racket/string racket/date racket/class racket/list) (require "debug.rkt" "readability.rkt") (provide setup) (define cd (current-directory)) +(define test-mode (make-parameter #f)) + +;; simple class for setup tasks +(define task% + (class object% + (init do-proc [undo-proc #f]) + (define this-do do-proc) + (define this-undo undo-proc) + (super-new) + (define/public (do-task) (this-do)) + (define/public (undo-task) (if this-undo (this-undo) (void))))) + +;; function for invoking method of multiple objects +(define-syntax send-each + (syntax-rules () + ;; invoke a method of every object in list + [(send-each objects do-method) + (for-each (λ(obj) (send obj do-method)) objects)] + ;; invoke a method of every object in list, but + ;; if error, invoke the undo method all the way backwards + ;; allows structured cleanup + [(send-each objects do-method undo-method) + (begin + (define (send-stack-inner objects-inner) + (if (empty? objects-inner) + (void) + (with-handlers ([exn:fail? (λ(err) + (begin + (send (car objects-inner) undo-method) + (raise err)))]) + (send (car objects-inner) do-method) + (send-stack-inner (cdr objects-inner))))) + ;; error has been handled all the way back up the stack + ;; so kill it here + (with-handlers ([exn:fail? (λ(err) (void))]) + (send-stack-inner objects)))])) + + (define (make-polcom-data racket-path) (format "#! ~a @@ -15,42 +54,86 @@ cd (format "~a at ~a" (make-datestamp) (make-timestamp)))) -(define (setup) - ; this function is just for export. - ; it hides the test-only parameter - (setup-testable #f)) -(define (setup-testable test-only) +;; task: get confirmation +(define (get-confirmation) (message (format "Set up ~a as a pollen directory? ['y' or 'yes']" cd)) - (define setup-confirm (if test-only "y" (->string (read)))) - (when (not (or (equal? setup-confirm "y") (equal? setup-confirm "yes"))) + (define setup-confirm (->string (read))) + (when (not (ormap (λ(input)(equal? setup-confirm input)) (list "y" "yes"))) + (error)) + (message (format "Setting up ~a as a pollen directory" cd))) + +(define (abort-confirmation) + (message "Aborting setup")) + +(define confirm-setup + (new task% + [do-proc get-confirmation] + [undo-proc abort-confirmation])) + + +;; task: make polcom file +(define polcom-filename "polcom") + +(define (delete-polcom-file-if-existing) + (when (file-exists? polcom-filename) (begin - (message "Aborting setup") - (exit))) - (message (format "Setting up ~a as a pollen directory" cd)) - + (message (format "Deleting existing polcom file in ~a" cd)) + (delete-file polcom-filename)))) + +(define (save-polcom-file) (define racket-path (string-trim (with-output-to-string (λ() (system "which racket"))))) (define path-to-racket-exists? (> (len racket-path) 0)) (if path-to-racket-exists? - (let ([polcom-data (make-polcom-data racket-path)] - [polcom-filename "polcom"]) + (let ([polcom-data (make-polcom-data racket-path)]) (message (format "Using ~a as racket path" racket-path)) - (when (file-exists? polcom-filename) - (begin - (message (format "Deleting existing polcom file in ~a" cd)) - (delete-file polcom-filename))) - (with-handlers ([exn:fail? (λ(e) (message "Couldn't write polcom file. Aborting setup"))]) - (when (not test-only) - (begin - (message (format "Creating new polcom file in ~a" cd)) - (display-to-file polcom-data polcom-filename) - (with-output-to-string (λ() (system (format "chmod 755 ~a" polcom-filename)))))) - (message "Setup complete") - (message (format "Run '~a~a start' to start project server" cd polcom-filename)) - (message (format "Or run '~a~a help' for a list of commands" cd polcom-filename)) - (when (not test-only) (exit)))) - (message "No path to racket binary. Aborting setup"))) + (delete-polcom-file-if-existing) + (message (format "Creating new polcom file in ~a" cd)) + (if (not (test-mode)) + (begin + (display-to-file polcom-data polcom-filename) + (with-output-to-string (λ() (system (format "chmod 755 ~a" polcom-filename))))) + (message "[test mode: file would be saved now]"))) + (begin + (message "No path to Racket binary") + (error)))) + +(define (abort-polcom-file) + (message "Couldn't create polcom file") + (delete-polcom-file-if-existing)) + +(define make-polcom + (new task% + [do-proc save-polcom-file] + [undo-proc abort-polcom-file])) + + +;; task: report success + +(define (success-messages) + (message "Setup complete") + (message (format "Run '~a~a start' to start project server" cd polcom-filename)) + (message (format "Or run '~a~a help' for a list of commands" cd polcom-filename)) + (when (not (test-mode)) (exit))) + +(define report-success + (new task% + [do-proc success-messages])) + + +(define tasks (list confirm-setup make-polcom report-success)) +(define (setup) + (send-each tasks do-task undo-task)) + + +;; better way to do this is to create separate removal tasks +;; (that may rely on some of the same intermediate functions) +;; so that errors can be caught on the way out too. +;; also, remove conflicts with existing racket name +;;(define (remove) +;; (send-each (reverse tasks) remove-task)) (module+ main - (setup-testable #t)) \ No newline at end of file + (parameterize ([test-mode #t]) + (setup))) \ No newline at end of file